| 1 |
#' Generate TNA-style Color Palette for Nodes |
|
| 2 |
#' |
|
| 3 |
#' Internal function that generates appropriate qualitative colors based on |
|
| 4 |
#' the number of states, following TNA's color palette logic. |
|
| 5 |
#' |
|
| 6 |
#' @param n_states Number of states (nodes) in the network. |
|
| 7 |
#' @return Character vector of colors. |
|
| 8 |
#' @keywords internal |
|
| 9 |
tna_color_palette <- function(n_states) {
|
|
| 10 | 45x |
color_group <- 4L - |
| 11 | 45x |
1L * (n_states <= 2) - |
| 12 | 45x |
1L * (n_states <= 8) - |
| 13 | 45x |
1L * (n_states <= 12) |
| 14 | ||
| 15 |
# Check for required packages with fallbacks |
|
| 16 | 45x |
switch(color_group, |
| 17 |
# 1-2 states: Accent palette (first n colors) |
|
| 18 | 8x |
if (has_package("RColorBrewer")) {
|
| 19 | 7x |
RColorBrewer::brewer.pal(n = 3, name = "Accent")[seq_len(n_states)] |
| 20 |
} else {
|
|
| 21 | 1x |
grDevices::hcl.colors(n_states, palette = "Set 2") |
| 22 |
}, |
|
| 23 |
# 3-8 states: Full Accent palette |
|
| 24 | 27x |
if (has_package("RColorBrewer")) {
|
| 25 | 26x |
RColorBrewer::brewer.pal(n = n_states, name = "Accent") |
| 26 |
} else {
|
|
| 27 | 1x |
grDevices::hcl.colors(n_states, palette = "Set 2") |
| 28 |
}, |
|
| 29 |
# 9-12 states: Set3 palette |
|
| 30 | 5x |
if (has_package("RColorBrewer")) {
|
| 31 | 4x |
RColorBrewer::brewer.pal(n = n_states, name = "Set3") |
| 32 |
} else {
|
|
| 33 | 1x |
grDevices::hcl.colors(n_states, palette = "Set 3") |
| 34 |
}, |
|
| 35 |
# 13+ states: colorspace qualitative HCL |
|
| 36 | 5x |
if (has_package("colorspace")) {
|
| 37 | 4x |
colorspace::qualitative_hcl(n = n_states, palette = "Set 3") |
| 38 |
} else {
|
|
| 39 | 1x |
grDevices::hcl.colors(n_states, palette = "Set 3") |
| 40 |
} |
|
| 41 |
) |
|
| 42 |
} |
|
| 43 | ||
| 44 |
#' Convert a tna object to cograph parameters |
|
| 45 |
#' |
|
| 46 |
#' Extracts the transition matrix, labels, and initial state probabilities |
|
| 47 |
#' from a \code{tna} object and plots with cograph. Initial probabilities
|
|
| 48 |
#' are mapped to donut fills. |
|
| 49 |
#' |
|
| 50 |
#' @param tna_object A \code{tna} object from \code{tna::tna()}
|
|
| 51 |
#' @param engine Which cograph renderer to use: \code{"splot"} or \code{"soplot"}.
|
|
| 52 |
#' Default: \code{"splot"}.
|
|
| 53 |
#' @param plot Logical. If TRUE (default), immediately plot using the chosen engine. |
|
| 54 |
#' @param weight_digits Number of decimal places to round edge weights to. Default 2. |
|
| 55 |
#' Edges that round to zero are removed unless \code{show_zero_edges = TRUE}.
|
|
| 56 |
#' @param show_zero_edges Logical. If TRUE, keep edges even if their weight rounds to |
|
| 57 |
#' zero. Default: FALSE. |
|
| 58 |
#' @param ... Additional parameters passed to the plotting engine (e.g., \code{layout},
|
|
| 59 |
#' \code{node_fill}, \code{donut_color}).
|
|
| 60 |
#' |
|
| 61 |
#' @details |
|
| 62 |
#' ## Conversion Process |
|
| 63 |
#' The tna object's transition matrix becomes edge weights, labels become |
|
| 64 |
#' node labels, and initial state probabilities (\code{inits}) are mapped to
|
|
| 65 |
#' \code{donut_fill} values to visualize starting state distributions.
|
|
| 66 |
#' |
|
| 67 |
#' TNA networks are always treated as directed because transition matrices |
|
| 68 |
#' represent directional state changes. |
|
| 69 |
#' |
|
| 70 |
#' The default \code{donut_inner_ratio} of 0.8 creates thin rings that
|
|
| 71 |
#' effectively visualize probability values without obscuring node labels. |
|
| 72 |
#' |
|
| 73 |
#' ## Parameter Mapping |
|
| 74 |
#' The following tna properties are automatically extracted: |
|
| 75 |
#' \itemize{
|
|
| 76 |
#' \item \strong{weights}: Transition matrix \code{->} edge weights
|
|
| 77 |
#' \item \strong{labels}: State labels \code{->} node labels
|
|
| 78 |
#' \item \strong{inits}: Initial probabilities \code{->} donut_fill (0-1 scale)
|
|
| 79 |
#' } |
|
| 80 |
#' |
|
| 81 |
#' ## TNA Visual Defaults |
|
| 82 |
#' The following visual defaults are applied for TNA plots (all can be overridden via \code{...}):
|
|
| 83 |
#' \itemize{
|
|
| 84 |
#' \item \code{layout = "oval"}: Oval/elliptical node arrangement
|
|
| 85 |
#' \item \code{node_fill}: Colors from TNA palette (Accent/Set3 based on state count)
|
|
| 86 |
#' \item \code{node_size = 7}: Larger nodes for readability
|
|
| 87 |
#' \item \code{arrow_size = 0.61}: Prominent directional arrows
|
|
| 88 |
#' \item \code{edge_color = "#003355"}: Dark blue edges
|
|
| 89 |
#' \item \code{edge_labels = TRUE}: Show transition weights on edges
|
|
| 90 |
#' \item \code{edge_label_size = 0.6}: Readable edge labels
|
|
| 91 |
#' \item \code{edge_label_position = 0.7}: Labels positioned toward target
|
|
| 92 |
#' \item \code{edge_start_style = "dotted"}: Dotted line at edge source
|
|
| 93 |
#' \item \code{edge_start_length = 0.2}: 20% of edge is dotted
|
|
| 94 |
#' } |
|
| 95 |
#' |
|
| 96 |
#' @return Invisibly, a named list of cograph parameters that can be passed to |
|
| 97 |
#' \code{splot()} or \code{soplot()}.
|
|
| 98 |
#' |
|
| 99 |
#' @seealso |
|
| 100 |
#' \code{\link{cograph}} for creating networks from scratch,
|
|
| 101 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting engines,
|
|
| 102 |
#' \code{\link{from_qgraph}} for qgraph object conversion
|
|
| 103 |
#' |
|
| 104 |
#' @examples |
|
| 105 |
#' \dontrun{
|
|
| 106 |
#' # Convert and plot a tna object |
|
| 107 |
#' library(tna) |
|
| 108 |
#' trans <- tna(transitions) |
|
| 109 |
#' from_tna(trans) # Plots with donut rings showing initial probabilities |
|
| 110 |
#' |
|
| 111 |
#' # Use soplot engine instead |
|
| 112 |
#' from_tna(trans, engine = "soplot") |
|
| 113 |
#' |
|
| 114 |
#' # Customize the visualization |
|
| 115 |
#' from_tna(trans, layout = "circle", donut_color = c("steelblue", "gray90"))
|
|
| 116 |
#' |
|
| 117 |
#' # Extract parameters without plotting |
|
| 118 |
#' params <- from_tna(trans, plot = FALSE) |
|
| 119 |
#' # Modify and plot manually |
|
| 120 |
#' params$node_fill <- "coral" |
|
| 121 |
#' do.call(splot, params) |
|
| 122 |
#' } |
|
| 123 |
#' |
|
| 124 |
#' @export |
|
| 125 |
from_tna <- function(tna_object, engine = c("splot", "soplot"), plot = TRUE,
|
|
| 126 |
weight_digits = 2, show_zero_edges = FALSE, ...) {
|
|
| 127 | 29x |
engine <- match.arg(engine) |
| 128 | ||
| 129 | 29x |
if (!inherits(tna_object, "tna")) {
|
| 130 | 6x |
stop("Input does not appear to be a tna object", call. = FALSE)
|
| 131 |
} |
|
| 132 | ||
| 133 | 23x |
overrides <- list(...) |
| 134 | ||
| 135 |
# --- Weights matrix --- |
|
| 136 | 23x |
x <- tna_object$weights |
| 137 | ||
| 138 |
# --- Build params --- |
|
| 139 | 23x |
n_states <- nrow(x) |
| 140 | ||
| 141 | 23x |
params <- list( |
| 142 | 23x |
x = x, |
| 143 | 23x |
labels = tna_object$labels, |
| 144 | 23x |
directed = TRUE, |
| 145 | 23x |
weight_digits = weight_digits, |
| 146 | 23x |
donut_fill = as.numeric(tna_object$inits), |
| 147 | 23x |
donut_inner_ratio = 0.8, |
| 148 | 23x |
donut_empty = FALSE |
| 149 |
) |
|
| 150 | ||
| 151 |
# --- TNA-specific visual defaults (can be overridden via ...) --- |
|
| 152 | 23x |
params$node_fill <- tna_color_palette(n_states) |
| 153 | 23x |
params$layout <- "oval" |
| 154 | 23x |
params$arrow_size <- 0.61 |
| 155 | 23x |
params$edge_labels <- TRUE |
| 156 | 23x |
params$edge_label_size <- 0.6 |
| 157 | 23x |
params$edge_color <- "#003355" |
| 158 | 23x |
params$edge_label_position <- 0.7 |
| 159 | 23x |
params$node_size <- 7 |
| 160 | 23x |
params$edge_start_length <- 0.2 |
| 161 | 23x |
params$edge_start_style <- "dotted" |
| 162 | ||
| 163 |
# --- Apply overrides --- |
|
| 164 | 23x |
for (nm in names(overrides)) {
|
| 165 | 4x |
params[[nm]] <- overrides[[nm]] |
| 166 |
} |
|
| 167 | ||
| 168 |
# --- Plot --- |
|
| 169 | 23x |
if (plot) {
|
| 170 | 3x |
plot_params <- params |
| 171 | 3x |
if (engine == "soplot") {
|
| 172 | 1x |
plot_params$network <- plot_params$x |
| 173 | 1x |
plot_params$x <- NULL |
| 174 |
} |
|
| 175 | 3x |
plot_fn <- switch(engine, splot = splot, soplot = soplot) |
| 176 | 3x |
accepted <- names(formals(plot_fn)) |
| 177 | 3x |
if (!"..." %in% accepted) {
|
| 178 | 1x |
plot_params <- plot_params[intersect(names(plot_params), accepted)] |
| 179 |
} |
|
| 180 | 3x |
do.call(plot_fn, plot_params) |
| 181 |
} |
|
| 182 | ||
| 183 | 23x |
invisible(params) |
| 184 |
} |
|
| 185 | ||
| 186 |
#' Convert a qgraph object to cograph parameters |
|
| 187 |
#' |
|
| 188 |
#' Extracts the network, layout, and all relevant arguments from a qgraph |
|
| 189 |
#' object and passes them to a cograph plotting engine. Reads resolved values |
|
| 190 |
#' from \code{graphAttributes} rather than raw \code{Arguments}.
|
|
| 191 |
#' |
|
| 192 |
#' @param qgraph_object Return value of \code{qgraph::qgraph()}
|
|
| 193 |
#' @param engine Which cograph renderer to use: \code{"splot"} or \code{"soplot"}.
|
|
| 194 |
#' Default: \code{"splot"}.
|
|
| 195 |
#' @param plot Logical. If TRUE (default), immediately plot using the chosen engine. |
|
| 196 |
#' @param weight_digits Number of decimal places to round edge weights to. Default 2. |
|
| 197 |
#' Edges that round to zero are removed unless \code{show_zero_edges = TRUE}.
|
|
| 198 |
#' @param show_zero_edges Logical. If TRUE, keep edges even if their weight rounds to |
|
| 199 |
#' zero. Default: FALSE. |
|
| 200 |
#' @param ... Override any extracted parameter. Use qgraph-style names (e.g., |
|
| 201 |
#' \code{minimum}) or cograph names (e.g., \code{threshold}).
|
|
| 202 |
#' |
|
| 203 |
#' @details |
|
| 204 |
#' ## Parameter Mapping |
|
| 205 |
#' The following qgraph parameters are automatically extracted and mapped to |
|
| 206 |
#' cograph equivalents: |
|
| 207 |
#' |
|
| 208 |
#' \strong{Node properties:}
|
|
| 209 |
#' \itemize{
|
|
| 210 |
#' \item \code{labels}/\code{names} \code{->} \code{labels}
|
|
| 211 |
#' \item \code{color} \code{->} \code{node_fill}
|
|
| 212 |
#' \item \code{width} \code{->} \code{node_size} (scaled by 1.3x)
|
|
| 213 |
#' \item \code{shape} \code{->} \code{node_shape} (mapped to cograph equivalents)
|
|
| 214 |
#' \item \code{border.color} \code{->} \code{node_border_color}
|
|
| 215 |
#' \item \code{border.width} \code{->} \code{node_border_width}
|
|
| 216 |
#' \item \code{label.cex} \code{->} \code{label_size}
|
|
| 217 |
#' \item \code{label.color} \code{->} \code{label_color}
|
|
| 218 |
#' } |
|
| 219 |
#' |
|
| 220 |
#' \strong{Edge properties:}
|
|
| 221 |
#' \itemize{
|
|
| 222 |
#' \item \code{labels} \code{->} \code{edge_labels}
|
|
| 223 |
#' \item \code{label.cex} \code{->} \code{edge_label_size} (scaled by 0.5x)
|
|
| 224 |
#' \item \code{lty} \code{->} \code{edge_style} (numeric to name conversion)
|
|
| 225 |
#' \item \code{curve} \code{->} \code{curvature}
|
|
| 226 |
#' \item \code{asize} \code{->} \code{arrow_size} (scaled by 0.3x)
|
|
| 227 |
#' } |
|
| 228 |
#' |
|
| 229 |
#' \strong{Graph properties:}
|
|
| 230 |
#' \itemize{
|
|
| 231 |
#' \item \code{minimum} \code{->} \code{threshold}
|
|
| 232 |
#' \item \code{maximum} \code{->} \code{maximum}
|
|
| 233 |
#' \item \code{groups} \code{->} \code{groups}
|
|
| 234 |
#' \item \code{directed} \code{->} \code{directed}
|
|
| 235 |
#' \item \code{posCol}/\code{negCol} \code{->} \code{edge_positive_color}/\code{edge_negative_color}
|
|
| 236 |
#' } |
|
| 237 |
#' |
|
| 238 |
#' \strong{Pie/Donut:}
|
|
| 239 |
#' \itemize{
|
|
| 240 |
#' \item \code{pie} values \code{->} \code{donut_fill} with \code{donut_inner_ratio=0.8}
|
|
| 241 |
#' \item \code{pieColor} \code{->} \code{donut_color}
|
|
| 242 |
#' } |
|
| 243 |
#' |
|
| 244 |
#' ## Important Notes |
|
| 245 |
#' \itemize{
|
|
| 246 |
#' \item \strong{edge_color and edge_width are NOT extracted} because qgraph bakes
|
|
| 247 |
#' its cut-based fading into these vectors, producing near-invisible edges. |
|
| 248 |
#' cograph applies its own weight-based styling instead. |
|
| 249 |
#' \item The \code{cut} parameter is also not passed because it causes faint edges
|
|
| 250 |
#' with hanging labels. |
|
| 251 |
#' \item Layout coordinates from qgraph are preserved with \code{rescale=FALSE}.
|
|
| 252 |
#' \item If you override layout, rescale is automatically re-enabled. |
|
| 253 |
#' } |
|
| 254 |
#' |
|
| 255 |
#' @return Invisibly, a named list of cograph parameters that can be passed to |
|
| 256 |
#' \code{splot()} or \code{soplot()}.
|
|
| 257 |
#' |
|
| 258 |
#' @seealso |
|
| 259 |
#' \code{\link{cograph}} for creating networks from scratch,
|
|
| 260 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting engines,
|
|
| 261 |
#' \code{\link{from_tna}} for tna object conversion
|
|
| 262 |
#' |
|
| 263 |
#' @examples |
|
| 264 |
#' \dontrun{
|
|
| 265 |
#' # Convert and plot a qgraph object |
|
| 266 |
#' library(qgraph) |
|
| 267 |
#' adj <- matrix(c(0, .5, .3, .5, 0, .4, .3, .4, 0), 3, 3) |
|
| 268 |
#' q <- qgraph(adj) |
|
| 269 |
#' from_qgraph(q) # Plots with splot |
|
| 270 |
#' |
|
| 271 |
#' # Use soplot engine instead |
|
| 272 |
#' from_qgraph(q, engine = "soplot") |
|
| 273 |
#' |
|
| 274 |
#' # Override extracted parameters |
|
| 275 |
#' from_qgraph(q, node_fill = "steelblue", layout = "circle") |
|
| 276 |
#' |
|
| 277 |
#' # Extract parameters without plotting |
|
| 278 |
#' params <- from_qgraph(q, plot = FALSE) |
|
| 279 |
#' names(params) # See what was extracted |
|
| 280 |
#' |
|
| 281 |
#' # Works with themed qgraph objects |
|
| 282 |
#' q_themed <- qgraph(adj, theme = "colorblind", posCol = "blue") |
|
| 283 |
#' from_qgraph(q_themed) |
|
| 284 |
#' } |
|
| 285 |
#' |
|
| 286 |
#' @export |
|
| 287 |
from_qgraph <- function(qgraph_object, engine = c("splot", "soplot"), plot = TRUE,
|
|
| 288 |
weight_digits = 2, show_zero_edges = FALSE, ...) {
|
|
| 289 | 30x |
engine <- match.arg(engine) |
| 290 | ||
| 291 | 30x |
if (!inherits(qgraph_object, "qgraph") && is.null(qgraph_object$Arguments)) {
|
| 292 | 5x |
stop("Input does not appear to be a qgraph object (missing 'Arguments' field)")
|
| 293 |
} |
|
| 294 | ||
| 295 | 23x |
q <- qgraph_object |
| 296 | 23x |
args <- q$Arguments |
| 297 | 23x |
ga_nodes <- q$graphAttributes$Nodes |
| 298 | 23x |
ga_edges <- q$graphAttributes$Edges |
| 299 | 23x |
ga_graph <- q$graphAttributes$Graph |
| 300 | 23x |
overrides <- list(...) |
| 301 | ||
| 302 |
# --- Input matrix --- |
|
| 303 | 23x |
x <- args$input |
| 304 | 23x |
el <- q$Edgelist |
| 305 | 23x |
if (is.null(x)) {
|
| 306 | 1x |
n <- length(ga_nodes$names) |
| 307 | 1x |
if (is.null(n) || n == 0) n <- max(c(el$from, el$to)) |
| 308 | 1x |
x <- matrix(0, n, n) |
| 309 | 1x |
for (i in seq_along(el$from)) {
|
| 310 | 1x |
x[el$from[i], el$to[i]] <- el$weight[i] |
| 311 |
} |
|
| 312 |
} |
|
| 313 | 22x |
n <- nrow(x) |
| 314 | ||
| 315 |
# --- Build params --- |
|
| 316 | 22x |
params <- list(x = x, weight_digits = weight_digits) |
| 317 | ||
| 318 |
# Layout: use computed coordinates |
|
| 319 | 22x |
if (!is.null(q$layout)) {
|
| 320 | 22x |
params$layout <- q$layout |
| 321 | 22x |
params$rescale <- FALSE |
| 322 |
} |
|
| 323 | ||
| 324 |
# --- Node aesthetics from graphAttributes$Nodes --- |
|
| 325 | 18x |
if (!is.null(ga_nodes$labels)) params$labels <- ga_nodes$labels |
| 326 | 4x |
else if (!is.null(ga_nodes$names)) params$labels <- ga_nodes$names |
| 327 | 14x |
if (!is.null(ga_nodes$color)) params$node_fill <- ga_nodes$color |
| 328 | 14x |
if (!is.null(ga_nodes$width)) params$node_size <- ga_nodes$width * 1.3 |
| 329 | 15x |
if (!is.null(ga_nodes$shape)) params$node_shape <- map_qgraph_shape(ga_nodes$shape) |
| 330 | 14x |
if (!is.null(ga_nodes$border.color)) params$node_border_color <- ga_nodes$border.color |
| 331 | 14x |
if (!is.null(ga_nodes$border.width)) params$node_border_width <- ga_nodes$border.width |
| 332 | 14x |
if (!is.null(ga_nodes$label.cex)) params$label_size <- ga_nodes$label.cex |
| 333 | 14x |
if (!is.null(ga_nodes$label.color)) params$label_color <- ga_nodes$label.color |
| 334 | ||
| 335 |
# --- Edge colors from qgraph arguments --- |
|
| 336 | 1x |
if (!is.null(args$posCol)) params$edge_positive_color <- args$posCol |
| 337 | 1x |
if (!is.null(args$negCol)) params$edge_negative_color <- args$negCol |
| 338 | 1x |
if (!is.null(args$theme)) params$theme <- args$theme |
| 339 | ||
| 340 |
# --- Pie → Donut mapping --- |
|
| 341 |
# qgraph pie values are single values per node (e.g. from tna) |
|
| 342 |
# Use graphAttributes$Nodes$pie which has the resolved values |
|
| 343 | 22x |
pie_data <- ga_nodes$pie |
| 344 | 22x |
if (!is.null(pie_data)) {
|
| 345 | 5x |
n_nodes <- if (is.matrix(x)) nrow(x) else length(ga_nodes$names) |
| 346 | 5x |
if (is.list(pie_data)) {
|
| 347 | 1x |
fill_vec <- vapply(pie_data, function(v) {
|
| 348 | 3x |
if (is.null(v) || all(is.na(v))) NA_real_ else v[1] |
| 349 | 1x |
}, numeric(1)) |
| 350 |
} else {
|
|
| 351 | 4x |
fill_vec <- as.numeric(pie_data) |
| 352 |
} |
|
| 353 | 5x |
if (length(fill_vec) < n_nodes) {
|
| 354 | 1x |
fill_vec <- c(fill_vec, rep(NA_real_, n_nodes - length(fill_vec))) |
| 355 |
} |
|
| 356 | 5x |
params$donut_fill <- fill_vec |
| 357 | 5x |
params$donut_inner_ratio <- 0.8 |
| 358 | 5x |
params$donut_empty <- FALSE |
| 359 |
} |
|
| 360 | 22x |
if (!is.null(ga_nodes$pieColor) && !all(is.na(ga_nodes$pieColor))) |
| 361 | 1x |
params$donut_color <- ga_nodes$pieColor |
| 362 | 22x |
if (!is.null(args$pieColor) && is.null(params$donut_color)) |
| 363 | 1x |
params$donut_color <- args$pieColor |
| 364 | ||
| 365 |
# --- Reorder per-edge vectors via matrix intermediary --- |
|
| 366 |
# qgraph's Edgelist order may differ from cograph's which(x!=0, arr.ind=TRUE) order. |
|
| 367 |
# Place each per-edge vector into an n×n matrix keyed by (from, to), then extract |
|
| 368 |
# in the order cograph will use. |
|
| 369 | 22x |
edge_vec_to_cograph_order <- function(v) {
|
| 370 | 6x |
if (is.null(v) || length(v) != length(el$from)) return(v) |
| 371 | 72x |
mat <- matrix(NA, n, n) |
| 372 | 72x |
for (i in seq_len(length(el$from))) {
|
| 373 | 149x |
mat[el$from[i], el$to[i]] <- v[i] |
| 374 |
} |
|
| 375 | 72x |
directed <- if (!is.null(el$directed)) any(el$directed) else !isSymmetric(x) |
| 376 | 72x |
if (directed) {
|
| 377 | 9x |
idx <- which(x != 0, arr.ind = TRUE) |
| 378 |
} else {
|
|
| 379 | 63x |
idx <- which(upper.tri(x) & x != 0, arr.ind = TRUE) |
| 380 |
} |
|
| 381 | 72x |
mat[idx] |
| 382 |
} |
|
| 383 | ||
| 384 |
# --- Edge aesthetics from graphAttributes$Edges --- |
|
| 385 |
# edge_color and edge_width are intentionally not passed — qgraph bakes its |
|
| 386 |
# cut-based fading into these vectors, producing near-invisible edges. Let |
|
| 387 |
# cograph apply its own weight-based styling instead. |
|
| 388 | 14x |
if (!is.null(ga_edges$labels)) params$edge_labels <- edge_vec_to_cograph_order(ga_edges$labels) |
| 389 | 16x |
if (!is.null(ga_edges$label.cex)) params$edge_label_size <- edge_vec_to_cograph_order(ga_edges$label.cex) * 0.5 |
| 390 | 16x |
if (!is.null(ga_edges$lty)) params$edge_style <- map_qgraph_lty(edge_vec_to_cograph_order(ga_edges$lty)) |
| 391 | 22x |
if (!is.null(ga_edges$curve) && length(ga_edges$curve) == 1) |
| 392 | 7x |
params$curvature <- ga_edges$curve |
| 393 | 16x |
if (!is.null(ga_edges$asize)) params$arrow_size <- edge_vec_to_cograph_order(ga_edges$asize) * 0.3 |
| 394 | 16x |
if (!is.null(ga_edges$edge.label.position)) params$edge_label_position <- edge_vec_to_cograph_order(ga_edges$edge.label.position) |
| 395 | ||
| 396 |
# --- Graph-level from graphAttributes$Graph --- |
|
| 397 |
# cut is intentionally not passed — qgraph's cut causes faint edges with hanging labels |
|
| 398 | 14x |
if (!is.null(ga_graph$minimum)) params$threshold <- ga_graph$minimum |
| 399 | 14x |
if (!is.null(ga_graph$maximum)) params$maximum <- ga_graph$maximum |
| 400 | 14x |
if (!is.null(ga_graph$groups)) params$groups <- ga_graph$groups |
| 401 | ||
| 402 |
# --- Directedness from Edgelist --- |
|
| 403 | 22x |
if (!is.null(q$Edgelist$directed)) params$directed <- any(q$Edgelist$directed) |
| 404 | ||
| 405 |
# --- Apply overrides (user can override anything) --- |
|
| 406 |
# Map qgraph-style parameter names to cograph equivalents |
|
| 407 | 22x |
qgraph_to_cograph <- c(minimum = "threshold", cut = "edge_cutoff") |
| 408 | 22x |
for (nm in names(overrides)) {
|
| 409 | 4x |
cograph_nm <- if (nm %in% names(qgraph_to_cograph)) qgraph_to_cograph[[nm]] else nm |
| 410 | 4x |
params[[cograph_nm]] <- overrides[[nm]] |
| 411 |
} |
|
| 412 |
# If user overrides layout, remove rescale=FALSE so cograph rescales properly |
|
| 413 | 22x |
if ("layout" %in% names(overrides)) {
|
| 414 | 1x |
params$rescale <- NULL |
| 415 |
} |
|
| 416 | ||
| 417 |
# --- Plot --- |
|
| 418 | 22x |
if (plot) {
|
| 419 | 5x |
plot_params <- params |
| 420 | 5x |
if (engine == "soplot") {
|
| 421 | 2x |
plot_params$network <- plot_params$x |
| 422 | 2x |
plot_params$x <- NULL |
| 423 |
} |
|
| 424 | 5x |
plot_fn <- switch(engine, splot = splot, soplot = soplot) |
| 425 |
# Filter to only params accepted by the target engine |
|
| 426 | 5x |
accepted <- names(formals(plot_fn)) |
| 427 | 5x |
if (!"..." %in% accepted) {
|
| 428 | 2x |
plot_params <- plot_params[intersect(names(plot_params), accepted)] |
| 429 |
} |
|
| 430 |
# soplot expects scalar edge params; collapse per-edge vectors |
|
| 431 | 5x |
if (engine == "soplot") {
|
| 432 | 2x |
edge_scalar_params <- c("edge_style", "arrow_size", "edge_label_size",
|
| 433 | 2x |
"edge_label_position") |
| 434 | 2x |
for (ep in edge_scalar_params) {
|
| 435 | 8x |
v <- plot_params[[ep]] |
| 436 | 8x |
if (!is.null(v) && length(v) > 1) {
|
| 437 | 4x |
uv <- unique(v) |
| 438 | 4x |
plot_params[[ep]] <- if (length(uv) == 1) uv else uv[1] |
| 439 |
} |
|
| 440 |
} |
|
| 441 |
} |
|
| 442 | 5x |
do.call(plot_fn, plot_params) |
| 443 |
} |
|
| 444 | ||
| 445 | 22x |
invisible(params) |
| 446 |
} |
|
| 447 | ||
| 448 |
#' Map qgraph lty codes to cograph edge style names |
|
| 449 |
#' @param lty Numeric or character vector of R line types |
|
| 450 |
#' @return Character vector of cograph style names |
|
| 451 |
#' @keywords internal |
|
| 452 |
map_qgraph_lty <- function(lty) {
|
|
| 453 | 33x |
mapping <- c("1" = "solid", "2" = "dashed", "3" = "dotted",
|
| 454 | 33x |
"4" = "dotdash", "5" = "longdash", "6" = "twodash", |
| 455 | 33x |
"solid" = "solid", "dashed" = "dashed", "dotted" = "dotted", |
| 456 | 33x |
"longdash" = "longdash", "twodash" = "twodash") |
| 457 | 33x |
result <- mapping[as.character(lty)] |
| 458 | 33x |
result[is.na(result)] <- "solid" |
| 459 | 33x |
unname(result) |
| 460 |
} |
|
| 461 | ||
| 462 |
#' Map qgraph shape names to cograph equivalents |
|
| 463 |
#' @param shapes Character vector of qgraph shape names |
|
| 464 |
#' @return Character vector of cograph shape names |
|
| 465 |
#' @keywords internal |
|
| 466 |
map_qgraph_shape <- function(shapes) {
|
|
| 467 | 30x |
mapping <- c( |
| 468 | 30x |
"rectangle" = "square", |
| 469 | 30x |
"square" = "square", |
| 470 | 30x |
"circle" = "circle", |
| 471 | 30x |
"ellipse" = "circle", |
| 472 | 30x |
"triangle" = "triangle", |
| 473 | 30x |
"diamond" = "diamond" |
| 474 |
) |
|
| 475 | 30x |
result <- mapping[shapes] |
| 476 | 30x |
unknown <- is.na(result) |
| 477 | 30x |
result[unknown] <- shapes[unknown] |
| 478 | 30x |
unname(result) |
| 479 |
} |
| 1 |
#' @title Aesthetic Scale Functions |
|
| 2 |
#' @description Functions for creating aesthetic scales. |
|
| 3 |
#' @name aes-scales |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Create a Size Scale |
|
| 8 |
#' |
|
| 9 |
#' Map values to sizes. |
|
| 10 |
#' |
|
| 11 |
#' @param values Values to map. |
|
| 12 |
#' @param range Output size range. |
|
| 13 |
#' @param trans Transformation: "linear", "sqrt", "log". |
|
| 14 |
#' @return Scaled values. |
|
| 15 |
#' @keywords internal |
|
| 16 |
scale_size <- function(values, range = c(0.03, 0.1), trans = "linear") {
|
|
| 17 | 1x |
if (all(is.na(values))) return(rep(mean(range), length(values))) |
| 18 | ||
| 19 |
# Apply transformation |
|
| 20 | 8x |
trans_values <- switch(trans, |
| 21 | 8x |
linear = values, |
| 22 | 8x |
sqrt = sqrt(pmax(0, values)), |
| 23 | 8x |
log = log1p(pmax(0, values)), |
| 24 | 8x |
values |
| 25 |
) |
|
| 26 | ||
| 27 |
# Normalize |
|
| 28 | 8x |
val_range <- range(trans_values, na.rm = TRUE) |
| 29 | 8x |
if (diff(val_range) == 0) {
|
| 30 | 1x |
return(rep(mean(range), length(values))) |
| 31 |
} |
|
| 32 | ||
| 33 | 7x |
normalized <- (trans_values - val_range[1]) / diff(val_range) |
| 34 | 7x |
range[1] + normalized * diff(range) |
| 35 |
} |
|
| 36 | ||
| 37 |
#' Create a Color Scale |
|
| 38 |
#' |
|
| 39 |
#' Map values to colors. |
|
| 40 |
#' |
|
| 41 |
#' @param values Values to map. |
|
| 42 |
#' @param palette Color palette (vector of colors or palette function name). |
|
| 43 |
#' @param limits Optional range limits. |
|
| 44 |
#' @return Character vector of colors. |
|
| 45 |
#' @keywords internal |
|
| 46 |
scale_color <- function(values, palette = "viridis", limits = NULL) {
|
|
| 47 | 1x |
if (all(is.na(values))) return(rep("gray50", length(values)))
|
| 48 | ||
| 49 |
# Get colors |
|
| 50 | 5x |
if (is.character(palette) && length(palette) == 1) {
|
| 51 |
# Palette name |
|
| 52 | 2x |
pal_fn <- get_palette(palette) |
| 53 | 2x |
if (is.null(pal_fn)) {
|
| 54 |
# Try as a single color |
|
| 55 | 1x |
return(rep(palette, length(values))) |
| 56 |
} |
|
| 57 | 1x |
colors <- pal_fn(100) |
| 58 | 3x |
} else if (is.function(palette)) {
|
| 59 | 1x |
colors <- palette(100) |
| 60 |
} else {
|
|
| 61 | 2x |
colors <- palette |
| 62 |
} |
|
| 63 | ||
| 64 | 4x |
map_to_colors(values, colors, limits) |
| 65 |
} |
|
| 66 | ||
| 67 |
#' Create a Categorical Color Scale |
|
| 68 |
#' |
|
| 69 |
#' Map categorical values to colors. |
|
| 70 |
#' |
|
| 71 |
#' @param values Categorical values. |
|
| 72 |
#' @param palette Color palette. |
|
| 73 |
#' @return Character vector of colors. |
|
| 74 |
#' @keywords internal |
|
| 75 |
scale_color_discrete <- function(values, palette = "colorblind") {
|
|
| 76 | 5x |
values <- as.factor(values) |
| 77 | 5x |
n_levels <- length(levels(values)) |
| 78 | ||
| 79 |
# Get colors |
|
| 80 | 5x |
if (is.character(palette) && length(palette) == 1) {
|
| 81 | 2x |
pal_fn <- get_palette(palette) |
| 82 | 2x |
if (is.null(pal_fn)) {
|
| 83 | 1x |
colors <- rep(palette, n_levels) |
| 84 |
} else {
|
|
| 85 | 1x |
colors <- pal_fn(n_levels) |
| 86 |
} |
|
| 87 | 3x |
} else if (is.function(palette)) {
|
| 88 | 2x |
colors <- palette(n_levels) |
| 89 |
} else {
|
|
| 90 | 1x |
colors <- rep(palette, length.out = n_levels) |
| 91 |
} |
|
| 92 | ||
| 93 | 5x |
colors[as.integer(values)] |
| 94 |
} |
|
| 95 | ||
| 96 |
#' Create a Width Scale |
|
| 97 |
#' |
|
| 98 |
#' Map values to line widths. |
|
| 99 |
#' |
|
| 100 |
#' @param values Values to map. |
|
| 101 |
#' @param range Output width range. |
|
| 102 |
#' @return Scaled values. |
|
| 103 |
#' @keywords internal |
|
| 104 |
scale_width <- function(values, range = c(0.5, 3)) {
|
|
| 105 | 1x |
scale_size(values, range, trans = "linear") |
| 106 |
} |
|
| 107 | ||
| 108 |
#' Create an Alpha Scale |
|
| 109 |
#' |
|
| 110 |
#' Map values to transparency. |
|
| 111 |
#' |
|
| 112 |
#' @param values Values to map. |
|
| 113 |
#' @param range Output alpha range. |
|
| 114 |
#' @return Scaled values. |
|
| 115 |
#' @keywords internal |
|
| 116 |
scale_alpha <- function(values, range = c(0.3, 1)) {
|
|
| 117 | 2x |
scaled <- scale_size(values, range, trans = "linear") |
| 118 | 2x |
pmax(0, pmin(1, scaled)) |
| 119 |
} |
| 1 |
#' @title Group-based Layout |
|
| 2 |
#' @description Arrange nodes in groups, with each group in a circular arrangement. |
|
| 3 |
#' @name layout-groups |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Group-based Layout |
|
| 7 |
#' |
|
| 8 |
#' Arrange nodes based on group membership. Groups are positioned in a |
|
| 9 |
#' circular arrangement around the center, with nodes within each group |
|
| 10 |
#' also arranged in a circle. |
|
| 11 |
#' |
|
| 12 |
#' @param network A CographNetwork object. |
|
| 13 |
#' @param groups Vector specifying group membership for each node. |
|
| 14 |
#' Can be numeric, character, or factor. |
|
| 15 |
#' @param group_positions Optional list or data frame with x, y coordinates |
|
| 16 |
#' for each group center. |
|
| 17 |
#' @param inner_radius Radius of nodes within each group (default: 0.15). |
|
| 18 |
#' @param outer_radius Radius for positioning group centers (default: 0.35). |
|
| 19 |
#' @return Data frame with x, y coordinates. |
|
| 20 |
#' @export |
|
| 21 |
#' |
|
| 22 |
#' @examples |
|
| 23 |
#' # Create a network with groups |
|
| 24 |
#' adj <- matrix(0, 9, 9) |
|
| 25 |
#' adj[1, 2:3] <- 1; adj[2:3, 1] <- 1 # Group 1 |
|
| 26 |
#' adj[4, 5:6] <- 1; adj[5:6, 4] <- 1 # Group 2 |
|
| 27 |
#' adj[7, 8:9] <- 1; adj[8:9, 7] <- 1 # Group 3 |
|
| 28 |
#' net <- CographNetwork$new(adj) |
|
| 29 |
#' groups <- c(1, 1, 1, 2, 2, 2, 3, 3, 3) |
|
| 30 |
#' coords <- layout_groups(net, groups) |
|
| 31 |
layout_groups <- function(network, groups, group_positions = NULL, |
|
| 32 |
inner_radius = 0.15, outer_radius = 0.35) {
|
|
| 33 | ||
| 34 | 18x |
n <- network$n_nodes |
| 35 | ||
| 36 | 18x |
if (n == 0) {
|
| 37 | 1x |
return(data.frame(x = numeric(0), y = numeric(0))) |
| 38 |
} |
|
| 39 | ||
| 40 |
# Validate groups |
|
| 41 | 17x |
if (length(groups) != n) {
|
| 42 | 1x |
stop("groups must have length equal to number of nodes", call. = FALSE)
|
| 43 |
} |
|
| 44 | ||
| 45 |
# Convert to factor |
|
| 46 | 16x |
groups <- as.factor(groups) |
| 47 | 16x |
group_levels <- levels(groups) |
| 48 | 16x |
n_groups <- length(group_levels) |
| 49 | ||
| 50 |
# Calculate group center positions |
|
| 51 | 16x |
if (is.null(group_positions)) {
|
| 52 | 13x |
if (n_groups == 1) {
|
| 53 |
# Single group: center |
|
| 54 | 1x |
group_centers <- data.frame(x = 0.5, y = 0.5) |
| 55 |
} else {
|
|
| 56 |
# Multiple groups: arrange in circle |
|
| 57 | 12x |
angles <- seq(pi/2, pi/2 + 2 * pi * (1 - 1/n_groups), |
| 58 | 12x |
length.out = n_groups) |
| 59 | 12x |
group_centers <- data.frame( |
| 60 | 12x |
x = 0.5 + outer_radius * cos(angles), |
| 61 | 12x |
y = 0.5 + outer_radius * sin(angles) |
| 62 |
) |
|
| 63 |
} |
|
| 64 | 13x |
rownames(group_centers) <- group_levels |
| 65 |
} else {
|
|
| 66 | 3x |
if (is.data.frame(group_positions)) {
|
| 67 | 2x |
group_centers <- group_positions |
| 68 |
} else {
|
|
| 69 | 1x |
group_centers <- as.data.frame(group_positions) |
| 70 |
} |
|
| 71 |
} |
|
| 72 | ||
| 73 |
# Initialize coordinates |
|
| 74 | 16x |
coords <- data.frame(x = numeric(n), y = numeric(n)) |
| 75 | ||
| 76 |
# Position nodes within each group |
|
| 77 | 16x |
for (g in group_levels) {
|
| 78 |
# Get nodes in this group |
|
| 79 | 37x |
node_idx <- which(groups == g) |
| 80 | 37x |
n_in_group <- length(node_idx) |
| 81 | ||
| 82 | 1x |
if (n_in_group == 0) next |
| 83 | ||
| 84 |
# Group center |
|
| 85 | 36x |
g_idx <- match(g, group_levels) |
| 86 | 36x |
cx <- group_centers$x[g_idx] |
| 87 | 36x |
cy <- group_centers$y[g_idx] |
| 88 | ||
| 89 | 36x |
if (n_in_group == 1) {
|
| 90 |
# Single node: at center |
|
| 91 | 3x |
coords$x[node_idx] <- cx |
| 92 | 3x |
coords$y[node_idx] <- cy |
| 93 |
} else {
|
|
| 94 |
# Multiple nodes: arrange in circle |
|
| 95 | 33x |
angles <- seq(pi/2, pi/2 + 2 * pi * (1 - 1/n_in_group), |
| 96 | 33x |
length.out = n_in_group) |
| 97 | 33x |
coords$x[node_idx] <- cx + inner_radius * cos(angles) |
| 98 | 33x |
coords$y[node_idx] <- cy + inner_radius * sin(angles) |
| 99 |
} |
|
| 100 |
} |
|
| 101 | ||
| 102 | 16x |
coords |
| 103 |
} |
| 1 |
#' @title Basic Node Shapes |
|
| 2 |
#' @description Basic node shape drawing functions. |
|
| 3 |
#' @name shapes-basic |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Draw Circle Node |
|
| 8 |
#' @keywords internal |
|
| 9 |
draw_circle <- function(x, y, size, fill, border_color, border_width, |
|
| 10 |
alpha = 1, ...) {
|
|
| 11 |
# Convert colors with alpha |
|
| 12 | 1495x |
fill_col <- adjust_alpha(fill, alpha) |
| 13 | 1495x |
border_col <- adjust_alpha(border_color, alpha) |
| 14 | ||
| 15 | 1495x |
grid::circleGrob( |
| 16 | 1495x |
x = grid::unit(x, "npc"), |
| 17 | 1495x |
y = grid::unit(y, "npc"), |
| 18 | 1495x |
r = grid::unit(size, "npc"), |
| 19 | 1495x |
gp = grid::gpar( |
| 20 | 1495x |
fill = fill_col, |
| 21 | 1495x |
col = border_col, |
| 22 | 1495x |
lwd = border_width |
| 23 |
) |
|
| 24 |
) |
|
| 25 |
} |
|
| 26 | ||
| 27 |
#' Draw Square Node |
|
| 28 |
#' @keywords internal |
|
| 29 |
draw_square <- function(x, y, size, fill, border_color, border_width, |
|
| 30 |
alpha = 1, ...) {
|
|
| 31 | 23x |
fill_col <- adjust_alpha(fill, alpha) |
| 32 | 23x |
border_col <- adjust_alpha(border_color, alpha) |
| 33 | ||
| 34 | 23x |
grid::rectGrob( |
| 35 | 23x |
x = grid::unit(x, "npc"), |
| 36 | 23x |
y = grid::unit(y, "npc"), |
| 37 | 23x |
width = grid::unit(size * 2, "npc"), |
| 38 | 23x |
height = grid::unit(size * 2, "npc"), |
| 39 | 23x |
gp = grid::gpar( |
| 40 | 23x |
fill = fill_col, |
| 41 | 23x |
col = border_col, |
| 42 | 23x |
lwd = border_width |
| 43 |
) |
|
| 44 |
) |
|
| 45 |
} |
|
| 46 | ||
| 47 |
#' Draw Triangle Node |
|
| 48 |
#' @keywords internal |
|
| 49 |
draw_triangle <- function(x, y, size, fill, border_color, border_width, |
|
| 50 |
alpha = 1, ...) {
|
|
| 51 | 25x |
fill_col <- adjust_alpha(fill, alpha) |
| 52 | 25x |
border_col <- adjust_alpha(border_color, alpha) |
| 53 | ||
| 54 |
# Equilateral triangle points |
|
| 55 | 25x |
angles <- c(pi/2, pi/2 + 2*pi/3, pi/2 + 4*pi/3) |
| 56 | 25x |
xs <- x + size * cos(angles) |
| 57 | 25x |
ys <- y + size * sin(angles) |
| 58 | ||
| 59 | 25x |
grid::polygonGrob( |
| 60 | 25x |
x = grid::unit(xs, "npc"), |
| 61 | 25x |
y = grid::unit(ys, "npc"), |
| 62 | 25x |
gp = grid::gpar( |
| 63 | 25x |
fill = fill_col, |
| 64 | 25x |
col = border_col, |
| 65 | 25x |
lwd = border_width |
| 66 |
) |
|
| 67 |
) |
|
| 68 |
} |
|
| 69 | ||
| 70 |
#' Draw Diamond Node |
|
| 71 |
#' @keywords internal |
|
| 72 |
draw_diamond <- function(x, y, size, fill, border_color, border_width, |
|
| 73 |
alpha = 1, ...) {
|
|
| 74 | 24x |
fill_col <- adjust_alpha(fill, alpha) |
| 75 | 24x |
border_col <- adjust_alpha(border_color, alpha) |
| 76 | ||
| 77 |
# Diamond (rotated square) |
|
| 78 | 24x |
angles <- c(0, pi/2, pi, 3*pi/2) |
| 79 | 24x |
xs <- x + size * cos(angles) |
| 80 | 24x |
ys <- y + size * sin(angles) |
| 81 | ||
| 82 | 24x |
grid::polygonGrob( |
| 83 | 24x |
x = grid::unit(xs, "npc"), |
| 84 | 24x |
y = grid::unit(ys, "npc"), |
| 85 | 24x |
gp = grid::gpar( |
| 86 | 24x |
fill = fill_col, |
| 87 | 24x |
col = border_col, |
| 88 | 24x |
lwd = border_width |
| 89 |
) |
|
| 90 |
) |
|
| 91 |
} |
|
| 92 | ||
| 93 |
#' Draw Pentagon Node |
|
| 94 |
#' @keywords internal |
|
| 95 |
draw_pentagon <- function(x, y, size, fill, border_color, border_width, |
|
| 96 |
alpha = 1, ...) {
|
|
| 97 | 10x |
fill_col <- adjust_alpha(fill, alpha) |
| 98 | 10x |
border_col <- adjust_alpha(border_color, alpha) |
| 99 | ||
| 100 | 10x |
angles <- seq(pi/2, pi/2 + 2*pi * (4/5), length.out = 5) |
| 101 | 10x |
xs <- x + size * cos(angles) |
| 102 | 10x |
ys <- y + size * sin(angles) |
| 103 | ||
| 104 | 10x |
grid::polygonGrob( |
| 105 | 10x |
x = grid::unit(xs, "npc"), |
| 106 | 10x |
y = grid::unit(ys, "npc"), |
| 107 | 10x |
gp = grid::gpar( |
| 108 | 10x |
fill = fill_col, |
| 109 | 10x |
col = border_col, |
| 110 | 10x |
lwd = border_width |
| 111 |
) |
|
| 112 |
) |
|
| 113 |
} |
|
| 114 | ||
| 115 |
#' Draw Hexagon Node |
|
| 116 |
#' @keywords internal |
|
| 117 |
draw_hexagon <- function(x, y, size, fill, border_color, border_width, |
|
| 118 |
alpha = 1, ...) {
|
|
| 119 | 11x |
fill_col <- adjust_alpha(fill, alpha) |
| 120 | 11x |
border_col <- adjust_alpha(border_color, alpha) |
| 121 | ||
| 122 | 11x |
angles <- seq(0, 2*pi * (5/6), length.out = 6) |
| 123 | 11x |
xs <- x + size * cos(angles) |
| 124 | 11x |
ys <- y + size * sin(angles) |
| 125 | ||
| 126 | 11x |
grid::polygonGrob( |
| 127 | 11x |
x = grid::unit(xs, "npc"), |
| 128 | 11x |
y = grid::unit(ys, "npc"), |
| 129 | 11x |
gp = grid::gpar( |
| 130 | 11x |
fill = fill_col, |
| 131 | 11x |
col = border_col, |
| 132 | 11x |
lwd = border_width |
| 133 |
) |
|
| 134 |
) |
|
| 135 |
} |
| 1 |
#' @title Base R Edge Rendering |
|
| 2 |
#' @description Edge drawing functions for splot() using base R graphics. |
|
| 3 |
#' @name splot-edges |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Find Split Index for Curve Based on Arc Length Fraction |
|
| 8 |
#' |
|
| 9 |
#' Calculates the index at which to split a curve's coordinate arrays |
|
| 10 |
#' so that the first segment covers a given fraction of the total arc length. |
|
| 11 |
#' |
|
| 12 |
#' @param x,y Vectors of curve coordinates. |
|
| 13 |
#' @param fraction Desired fraction of total arc length (0-1). |
|
| 14 |
#' @return Index at which to split the arrays. |
|
| 15 |
#' @keywords internal |
|
| 16 |
find_curve_split_index <- function(x, y, fraction) {
|
|
| 17 | 266x |
n <- length(x) |
| 18 | 4x |
if (n < 2 || fraction <= 0) return(1) |
| 19 | 3x |
if (fraction >= 1) return(n) |
| 20 | ||
| 21 |
# Calculate cumulative arc length |
|
| 22 | 259x |
dx <- diff(x) |
| 23 | 259x |
dy <- diff(y) |
| 24 | 259x |
segment_lengths <- sqrt(dx^2 + dy^2) |
| 25 | 259x |
cumulative_length <- c(0, cumsum(segment_lengths)) |
| 26 | 259x |
total_length <- cumulative_length[n] |
| 27 | ||
| 28 | 1x |
if (total_length < 1e-10) return(1) |
| 29 | ||
| 30 |
# Find index where cumulative length crosses target |
|
| 31 | 258x |
target_length <- total_length * fraction |
| 32 | 258x |
split_idx <- which(cumulative_length >= target_length)[1] |
| 33 | ||
| 34 |
# Ensure at least 2 points in each segment |
|
| 35 | 258x |
split_idx <- max(2, min(split_idx, n - 1)) |
| 36 | ||
| 37 | 258x |
return(split_idx) |
| 38 |
} |
|
| 39 | ||
| 40 |
#' Draw Curve with Optional Start Segment |
|
| 41 |
#' |
|
| 42 |
#' Draws a curve (as lines) with an optional differently-styled start segment. |
|
| 43 |
#' Used internally to support dashed/dotted start segments for edge direction clarity. |
|
| 44 |
#' |
|
| 45 |
#' @param x,y Vectors of curve coordinates. |
|
| 46 |
#' @param col Line color. |
|
| 47 |
#' @param lwd Line width. |
|
| 48 |
#' @param lty Main line type. |
|
| 49 |
#' @param start_lty Line type for start segment. |
|
| 50 |
#' @param start_fraction Fraction of curve for start segment (0-0.5). |
|
| 51 |
#' @keywords internal |
|
| 52 |
draw_curve_with_start_segment <- function(x, y, col, lwd, lty, |
|
| 53 |
start_lty = 1, start_fraction = 0) {
|
|
| 54 | 453x |
n <- length(x) |
| 55 | 2x |
if (n < 2) return(invisible()) |
| 56 | ||
| 57 |
# If no split needed, draw single line |
|
| 58 | 451x |
if (start_fraction <= 0 || start_lty == lty) {
|
| 59 | 196x |
graphics::lines(x, y, col = col, lwd = lwd, lty = lty) |
| 60 | 196x |
return(invisible()) |
| 61 |
} |
|
| 62 | ||
| 63 |
# Find split index based on arc length |
|
| 64 | 255x |
split_idx <- find_curve_split_index(x, y, start_fraction) |
| 65 | ||
| 66 |
# Draw start segment (dashed/dotted) |
|
| 67 | 255x |
if (split_idx >= 2) {
|
| 68 | 255x |
graphics::lines(x[1:split_idx], y[1:split_idx], |
| 69 | 255x |
col = col, lwd = lwd, lty = start_lty) |
| 70 |
} |
|
| 71 | ||
| 72 |
# Draw main segment (solid) |
|
| 73 | 255x |
if (split_idx < n) {
|
| 74 | 255x |
graphics::lines(x[split_idx:n], y[split_idx:n], |
| 75 | 255x |
col = col, lwd = lwd, lty = lty) |
| 76 |
} |
|
| 77 | ||
| 78 | 255x |
invisible() |
| 79 |
} |
|
| 80 | ||
| 81 |
#' Draw Straight Edge |
|
| 82 |
#' |
|
| 83 |
#' Renders a straight edge between two points with optional arrow. |
|
| 84 |
#' |
|
| 85 |
#' @param x1,y1 Start point coordinates. |
|
| 86 |
#' @param x2,y2 End point coordinates. |
|
| 87 |
#' @param col Edge color. |
|
| 88 |
#' @param lwd Line width. |
|
| 89 |
#' @param lty Line type. |
|
| 90 |
#' @param arrow Logical: draw arrow at target? |
|
| 91 |
#' @param asize Arrow size. |
|
| 92 |
#' @param bidirectional Logical: draw arrow at source too? |
|
| 93 |
#' @param start_lty Line type for start segment. 1=solid (default), 2=dashed, 3=dotted. |
|
| 94 |
#' @param start_fraction Fraction of edge length for start segment (0-0.5). Default 0. |
|
| 95 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 96 |
#' @keywords internal |
|
| 97 |
draw_straight_edge_base <- function(x1, y1, x2, y2, col = "gray50", lwd = 1, |
|
| 98 |
lty = 1, arrow = TRUE, asize = 0.02, |
|
| 99 |
bidirectional = FALSE, |
|
| 100 |
start_lty = 1, start_fraction = 0, |
|
| 101 |
arrow_angle = pi/6) {
|
|
| 102 |
# Calculate angle |
|
| 103 | 2373x |
angle <- splot_angle(x1, y1, x2, y2) |
| 104 | ||
| 105 |
# qgraph-style: line ends at arrow base midpoint, arrow TIP at node boundary |
|
| 106 | 2373x |
if (arrow && asize > 0) {
|
| 107 |
# Get arrow base midpoint (where line should end) |
|
| 108 | 955x |
base_end <- arrow_base_midpoint(x2, y2, angle, asize, arrow_angle = arrow_angle) |
| 109 | 955x |
line_x2 <- base_end$x |
| 110 | 955x |
line_y2 <- base_end$y |
| 111 |
} else {
|
|
| 112 | 1418x |
line_x2 <- x2 |
| 113 | 1418x |
line_y2 <- y2 |
| 114 |
} |
|
| 115 | ||
| 116 |
# Shorten start if bidirectional |
|
| 117 | 2373x |
if (bidirectional && asize > 0) {
|
| 118 | 10x |
angle_back <- splot_angle(x2, y2, x1, y1) |
| 119 | 10x |
base_start <- arrow_base_midpoint(x1, y1, angle_back, asize, arrow_angle = arrow_angle) |
| 120 | 10x |
line_x1 <- base_start$x |
| 121 | 10x |
line_y1 <- base_start$y |
| 122 |
} else {
|
|
| 123 | 2363x |
line_x1 <- x1 |
| 124 | 2363x |
line_y1 <- y1 |
| 125 |
} |
|
| 126 | ||
| 127 |
# Draw line (ends at arrow base, not at tip) |
|
| 128 |
# If start_lty differs from main lty and start_fraction > 0, split into two segments |
|
| 129 | 2373x |
if (start_fraction > 0 && start_lty != lty) {
|
| 130 |
# Calculate split point |
|
| 131 | 831x |
split_x <- line_x1 + start_fraction * (line_x2 - line_x1) |
| 132 | 831x |
split_y <- line_y1 + start_fraction * (line_y2 - line_y1) |
| 133 | ||
| 134 |
# Draw start segment (dashed/dotted) |
|
| 135 | 831x |
graphics::lines( |
| 136 | 831x |
x = c(line_x1, split_x), |
| 137 | 831x |
y = c(line_y1, split_y), |
| 138 | 831x |
col = col, |
| 139 | 831x |
lwd = lwd, |
| 140 | 831x |
lty = start_lty |
| 141 |
) |
|
| 142 | ||
| 143 |
# Draw main segment (solid) |
|
| 144 | 831x |
graphics::lines( |
| 145 | 831x |
x = c(split_x, line_x2), |
| 146 | 831x |
y = c(split_y, line_y2), |
| 147 | 831x |
col = col, |
| 148 | 831x |
lwd = lwd, |
| 149 | 831x |
lty = lty |
| 150 |
) |
|
| 151 |
} else {
|
|
| 152 |
# Single line with uniform style |
|
| 153 | 1542x |
graphics::lines( |
| 154 | 1542x |
x = c(line_x1, line_x2), |
| 155 | 1542x |
y = c(line_y1, line_y2), |
| 156 | 1542x |
col = col, |
| 157 | 1542x |
lwd = lwd, |
| 158 | 1542x |
lty = lty |
| 159 |
) |
|
| 160 |
} |
|
| 161 | ||
| 162 |
# Draw arrow at target (TIP at node boundary) |
|
| 163 | 2373x |
if (arrow && asize > 0) {
|
| 164 | 955x |
draw_arrow_base(x2, y2, angle, asize, arrow_angle = arrow_angle, col = col) |
| 165 |
} |
|
| 166 | ||
| 167 |
# Draw arrow at source if bidirectional (TIP at node boundary) |
|
| 168 | 2373x |
if (bidirectional && asize > 0) {
|
| 169 | 10x |
angle_back <- splot_angle(x2, y2, x1, y1) |
| 170 | 10x |
draw_arrow_base(x1, y1, angle_back, asize, arrow_angle = arrow_angle, col = col) |
| 171 |
} |
|
| 172 |
} |
|
| 173 | ||
| 174 |
#' Draw Curved Edge with xspline (qgraph-style) |
|
| 175 |
#' |
|
| 176 |
#' Renders a curved edge using xspline() with optional arrow. |
|
| 177 |
#' Uses qgraph-style curve calculation for smooth, natural-looking curves. |
|
| 178 |
#' Curve direction is normalized so positive curve always bends the same |
|
| 179 |
#' visual direction regardless of edge orientation. |
|
| 180 |
#' |
|
| 181 |
#' @param x1,y1 Start point coordinates. |
|
| 182 |
#' @param x2,y2 End point coordinates. |
|
| 183 |
#' @param curve Curvature amount (positive = clockwise, negative = counterclockwise |
|
| 184 |
#' when looking from source to target). |
|
| 185 |
#' @param curvePivot Position along edge for control point (0-1). |
|
| 186 |
#' @param col Edge color. |
|
| 187 |
#' @param lwd Line width. |
|
| 188 |
#' @param lty Line type. |
|
| 189 |
#' @param arrow Logical: draw arrow at target? |
|
| 190 |
#' @param asize Arrow size. |
|
| 191 |
#' @param bidirectional Logical: draw arrow at source too? |
|
| 192 |
#' @param start_lty Line type for start segment. 1=solid (default), 2=dashed, 3=dotted. |
|
| 193 |
#' @param start_fraction Fraction of edge length for start segment (0-0.5). Default 0. |
|
| 194 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 195 |
#' @keywords internal |
|
| 196 |
draw_curved_edge_base <- function(x1, y1, x2, y2, curve = 0.2, curvePivot = 0.5, |
|
| 197 |
col = "gray50", lwd = 1, lty = 1, |
|
| 198 |
arrow = TRUE, asize = 0.02, |
|
| 199 |
bidirectional = FALSE, |
|
| 200 |
start_lty = 1, start_fraction = 0, |
|
| 201 |
arrow_angle = pi/6) {
|
|
| 202 | 441x |
if (abs(curve) < 1e-6) {
|
| 203 |
# Fall back to straight edge |
|
| 204 | 1x |
draw_straight_edge_base(x1, y1, x2, y2, col, lwd, lty, arrow, asize, bidirectional, |
| 205 | 1x |
start_lty, start_fraction, arrow_angle) |
| 206 | 1x |
return(invisible()) |
| 207 |
} |
|
| 208 | ||
| 209 |
# Edge vector and length |
|
| 210 | 440x |
dx <- x2 - x1 |
| 211 | 440x |
dy <- y2 - y1 |
| 212 | 440x |
len <- sqrt(dx^2 + dy^2) |
| 213 | ||
| 214 |
# Defensive check for empty or NA values |
|
| 215 | 440x |
if (length(len) == 0 || is.na(len) || len < 1e-10) {
|
| 216 | 2x |
return(invisible()) |
| 217 |
} |
|
| 218 | ||
| 219 | ||
| 220 |
# Perpendicular unit vector (rotated 90 degrees counter-clockwise) |
|
| 221 |
# Matches the (-dy, dx) convention used by the curve direction algorithm |
|
| 222 | 438x |
px <- -dy / len |
| 223 | 438x |
py <- dx / len |
| 224 | ||
| 225 |
# Curve offset: proportional to edge length, with minimum so short edges still visibly curve |
|
| 226 | 438x |
curve_offset <- curve * len * 0.25 |
| 227 | 438x |
min_offset <- abs(curve) * 0.3 # minimum offset ensures reciprocal edges are distinguishable |
| 228 | 438x |
if (abs(curve_offset) > 0 && abs(curve_offset) < min_offset) {
|
| 229 | 248x |
curve_offset <- sign(curve_offset) * min_offset |
| 230 |
} |
|
| 231 | ||
| 232 |
# Create smooth curve using multiple control points (qgraph approach) |
|
| 233 |
# Use 5 points for smoother curve: start, 1/4, mid, 3/4, end |
|
| 234 | 438x |
t_vals <- c(0, 0.25, 0.5, 0.75, 1) |
| 235 | 438x |
n_pts <- length(t_vals) |
| 236 | ||
| 237 | 438x |
ctrl_x <- numeric(n_pts) |
| 238 | 438x |
ctrl_y <- numeric(n_pts) |
| 239 | ||
| 240 | 438x |
for (i in seq_along(t_vals)) {
|
| 241 | 2190x |
t <- t_vals[i] |
| 242 |
# Base point along edge |
|
| 243 | 2190x |
bx <- x1 + t * dx |
| 244 | 2190x |
by <- y1 + t * dy |
| 245 | ||
| 246 |
# Parabolic offset - maximum at curvePivot, zero at ends |
|
| 247 |
# This creates a smooth symmetric curve |
|
| 248 | 2190x |
offset_factor <- 4 * t * (1 - t) # Parabola peaking at t=0.5 |
| 249 | ||
| 250 |
# Adjust for pivot position (shift the peak) |
|
| 251 | 2190x |
if (curvePivot != 0.5) {
|
| 252 |
# Skewed parabola |
|
| 253 | 25x |
if (t <= curvePivot) {
|
| 254 | 10x |
offset_factor <- (t / curvePivot)^2 * 4 * curvePivot * (1 - curvePivot) |
| 255 |
} else {
|
|
| 256 | 15x |
offset_factor <- ((1 - t) / (1 - curvePivot))^2 * 4 * curvePivot * (1 - curvePivot) |
| 257 |
} |
|
| 258 |
} |
|
| 259 | ||
| 260 | 2190x |
ctrl_x[i] <- bx + curve_offset * offset_factor * px |
| 261 | 2190x |
ctrl_y[i] <- by + curve_offset * offset_factor * py |
| 262 |
} |
|
| 263 | ||
| 264 |
# Generate smooth xspline through control points |
|
| 265 |
# shape = 1 for smooth interpolation, 0 for corners at endpoints |
|
| 266 | 438x |
spl <- graphics::xspline( |
| 267 | 438x |
x = ctrl_x, |
| 268 | 438x |
y = ctrl_y, |
| 269 | 438x |
shape = c(0, 1, 1, 1, 0), |
| 270 | 438x |
open = TRUE, |
| 271 | 438x |
draw = FALSE |
| 272 |
) |
|
| 273 | ||
| 274 |
# qgraph-style arrow positioning: |
|
| 275 |
# 1. Calculate arrow angle from curve direction |
|
| 276 |
# 2. Truncate curve to stop at arrow base |
|
| 277 |
# 3. Draw arrow with TIP at node boundary |
|
| 278 | ||
| 279 | 438x |
if (arrow && asize > 0) {
|
| 280 | 425x |
n <- length(spl$x) |
| 281 | ||
| 282 |
# 1. Calculate arrow angle from last curve segment |
|
| 283 | 425x |
idx <- max(1, n - 3) |
| 284 | 425x |
angle <- splot_angle(spl$x[idx], spl$y[idx], x2, y2) |
| 285 | ||
| 286 |
# 2. Find arrow base midpoint (where curve should end) |
|
| 287 | 425x |
base <- arrow_base_midpoint(x2, y2, angle, asize, arrow_angle = arrow_angle) |
| 288 | ||
| 289 |
# 3. Truncate curve: remove points inside arrow radius |
|
| 290 | 425x |
arrow_rad <- asize # Arrow extends this far back from tip |
| 291 | 425x |
dists <- sqrt((spl$x - x2)^2 + (spl$y - y2)^2) |
| 292 | 425x |
outside <- dists > arrow_rad |
| 293 | ||
| 294 |
# Keep only points outside the arrow (qgraph approach) |
|
| 295 | 425x |
keep_idx <- which(rev(cumsum(rev(outside)) > 0)) |
| 296 | ||
| 297 |
# 4. Draw truncated curve + line to arrow base |
|
| 298 | 425x |
if (length(keep_idx) > 0) {
|
| 299 | 425x |
curve_x <- c(spl$x[keep_idx], base$x) |
| 300 | 425x |
curve_y <- c(spl$y[keep_idx], base$y) |
| 301 | 425x |
draw_curve_with_start_segment(curve_x, curve_y, col, lwd, lty, |
| 302 | 425x |
start_lty, start_fraction) |
| 303 |
} |
|
| 304 | ||
| 305 |
# 5. Draw arrow with TIP at node boundary (x2, y2) |
|
| 306 | 425x |
draw_arrow_base(x2, y2, angle, asize, arrow_angle = arrow_angle, col = col) |
| 307 |
} else {
|
|
| 308 |
# No arrow - draw full curve |
|
| 309 | 13x |
draw_curve_with_start_segment(spl$x, spl$y, col, lwd, lty, |
| 310 | 13x |
start_lty, start_fraction) |
| 311 |
} |
|
| 312 | ||
| 313 |
# Draw arrow at source if bidirectional |
|
| 314 | 438x |
if (bidirectional && asize > 0) {
|
| 315 | 8x |
n <- length(spl$x) |
| 316 | ||
| 317 |
# Calculate angle from curve start |
|
| 318 | 8x |
idx <- min(n, 4) |
| 319 | 8x |
angle_back <- splot_angle(spl$x[idx], spl$y[idx], x1, y1) |
| 320 | ||
| 321 |
# Find arrow base midpoint at source |
|
| 322 | 8x |
base_start <- arrow_base_midpoint(x1, y1, angle_back, asize, arrow_angle = arrow_angle) |
| 323 | ||
| 324 |
# Truncate curve at source: remove points inside arrow radius |
|
| 325 | 8x |
dists_start <- sqrt((spl$x - x1)^2 + (spl$y - y1)^2) |
| 326 | 8x |
outside_start <- dists_start > asize |
| 327 | ||
| 328 |
# Keep only points outside the start arrow |
|
| 329 | 8x |
keep_idx_start <- which(cumsum(outside_start) > 0) |
| 330 | ||
| 331 |
# Redraw if we need to truncate the start (overwrites previous line) |
|
| 332 | 8x |
if (length(keep_idx_start) > 0 && length(keep_idx_start) < n) {
|
| 333 |
# Clear and redraw with both ends truncated |
|
| 334 | 8x |
curve_x <- c(base_start$x, spl$x[keep_idx_start]) |
| 335 | 8x |
curve_y <- c(base_start$y, spl$y[keep_idx_start]) |
| 336 | ||
| 337 |
# If target also has arrow, truncate that end too |
|
| 338 | 8x |
if (arrow && asize > 0) {
|
| 339 | 8x |
dists_end <- sqrt((curve_x - x2)^2 + (curve_y - y2)^2) |
| 340 | 8x |
outside_end <- dists_end > asize |
| 341 | 8x |
keep_end <- which(rev(cumsum(rev(outside_end)) > 0)) |
| 342 | 8x |
if (length(keep_end) > 0) {
|
| 343 | 8x |
angle_fwd <- splot_angle(spl$x[n-3], spl$y[n-3], x2, y2) |
| 344 | 8x |
base_end <- arrow_base_midpoint(x2, y2, angle_fwd, asize, arrow_angle = arrow_angle) |
| 345 | 8x |
curve_x <- c(curve_x[keep_end], base_end$x) |
| 346 | 8x |
curve_y <- c(curve_y[keep_end], base_end$y) |
| 347 |
} |
|
| 348 |
} |
|
| 349 | ||
| 350 | 8x |
draw_curve_with_start_segment(curve_x, curve_y, col, lwd, lty, |
| 351 | 8x |
start_lty, start_fraction) |
| 352 |
} |
|
| 353 | ||
| 354 |
# Draw arrow at source |
|
| 355 | 8x |
draw_arrow_base(x1, y1, angle_back, asize, arrow_angle = arrow_angle, col = col) |
| 356 |
} |
|
| 357 |
} |
|
| 358 | ||
| 359 |
#' Draw Self-Loop Edge (qgraph-style) |
|
| 360 |
#' |
|
| 361 |
#' Renders a self-loop (edge from node to itself) using a teardrop/circular |
|
| 362 |
#' loop shape similar to qgraph. |
|
| 363 |
#' |
|
| 364 |
#' @param x,y Node center coordinates. |
|
| 365 |
#' @param node_size Node radius. |
|
| 366 |
#' @param col Loop color. |
|
| 367 |
#' @param lwd Line width. |
|
| 368 |
#' @param lty Line type. |
|
| 369 |
#' @param rotation Angle in radians for loop direction (default: pi/2 = top). |
|
| 370 |
#' @param arrow Logical: draw arrow? |
|
| 371 |
#' @param asize Arrow size. |
|
| 372 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 373 |
#' @keywords internal |
|
| 374 |
draw_self_loop_base <- function(x, y, node_size, col = "gray50", lwd = 1, |
|
| 375 |
lty = 1, rotation = pi/2, arrow = TRUE, |
|
| 376 |
asize = 0.02, arrow_angle = pi/6) {
|
|
| 377 | ||
| 378 |
# qgraph-style loop: circular arc outside the node |
|
| 379 |
# Loop size proportional to node size |
|
| 380 | 58x |
loop_radius <- node_size * 0.8 |
| 381 | 58x |
loop_dist <- node_size + loop_radius * 0.9 # Center of loop circle |
| 382 | ||
| 383 |
# Center of the loop arc (outside the node) |
|
| 384 | 58x |
loop_cx <- x + loop_dist * cos(rotation) |
| 385 | 58x |
loop_cy <- y + loop_dist * sin(rotation) |
| 386 | ||
| 387 |
# Generate circular arc (about 300 degrees, leaving gap for arrow) |
|
| 388 | 58x |
n_pts <- 40 |
| 389 | 58x |
arc_start <- rotation + pi + 0.4 # Start angle (relative to loop center) |
| 390 | 58x |
arc_end <- rotation + pi - 0.4 # End angle |
| 391 | ||
| 392 |
# Handle angle wrapping |
|
| 393 | 58x |
if (arc_end < arc_start) {
|
| 394 | 58x |
arc_end <- arc_end + 2 * pi |
| 395 |
} |
|
| 396 | ||
| 397 | 58x |
angles <- seq(arc_start, arc_end, length.out = n_pts) |
| 398 | ||
| 399 | 58x |
loop_x <- loop_cx + loop_radius * cos(angles) |
| 400 | 58x |
loop_y <- loop_cy + loop_radius * sin(angles) |
| 401 | ||
| 402 |
# Draw the loop |
|
| 403 | 58x |
graphics::lines( |
| 404 | 58x |
x = loop_x, |
| 405 | 58x |
y = loop_y, |
| 406 | 58x |
col = col, |
| 407 | 58x |
lwd = lwd, |
| 408 | 58x |
lty = lty |
| 409 |
) |
|
| 410 | ||
| 411 |
# Draw arrow at end of loop |
|
| 412 | 58x |
if (arrow && asize > 0) {
|
| 413 | 55x |
n <- length(loop_x) |
| 414 |
# Arrow angle tangent to circle at endpoint |
|
| 415 | 55x |
angle <- splot_angle(loop_x[n-1], loop_y[n-1], loop_x[n], loop_y[n]) |
| 416 | 55x |
draw_arrow_base(loop_x[n], loop_y[n], angle, asize, arrow_angle = arrow_angle, col = col) |
| 417 |
} |
|
| 418 |
} |
|
| 419 | ||
| 420 |
#' Draw Edge Label |
|
| 421 |
#' |
|
| 422 |
#' Renders a label on an edge. |
|
| 423 |
#' |
|
| 424 |
#' @param x,y Label position coordinates. |
|
| 425 |
#' @param label Text to display. |
|
| 426 |
#' @param cex Character expansion factor. |
|
| 427 |
#' @param col Text color. |
|
| 428 |
#' @param bg Background color (or NA for none). |
|
| 429 |
#' @param font Font face. |
|
| 430 |
#' @param shadow Logical: enable drop shadow? |
|
| 431 |
#' @param shadow_color Shadow color. |
|
| 432 |
#' @param shadow_offset Shadow offset distance. |
|
| 433 |
#' @param shadow_alpha Shadow transparency. |
|
| 434 |
#' @keywords internal |
|
| 435 |
draw_edge_label_base <- function(x, y, label, cex = 0.8, col = "gray30", |
|
| 436 |
bg = "white", font = 1, |
|
| 437 |
shadow = FALSE, shadow_color = "gray40", |
|
| 438 |
shadow_offset = 0.5, shadow_alpha = 0.5) {
|
|
| 439 | 1198x |
if (is.null(label) || is.na(label) || label == "") {
|
| 440 | 6x |
return(invisible()) |
| 441 |
} |
|
| 442 | ||
| 443 |
# Draw background if specified |
|
| 444 | 1192x |
if (!is.na(bg) && !is.null(bg)) {
|
| 445 |
# Estimate text size for background |
|
| 446 | 1190x |
sw <- graphics::strwidth(label, cex = cex) |
| 447 | 1190x |
sh <- graphics::strheight(label, cex = cex) |
| 448 | 1190x |
pad <- 0.2 |
| 449 | ||
| 450 | 1190x |
graphics::rect( |
| 451 | 1190x |
xleft = x - sw/2 - sw*pad, |
| 452 | 1190x |
ybottom = y - sh/2 - sh*pad, |
| 453 | 1190x |
xright = x + sw/2 + sw*pad, |
| 454 | 1190x |
ytop = y + sh/2 + sh*pad, |
| 455 | 1190x |
col = bg, |
| 456 | 1190x |
border = NA |
| 457 |
) |
|
| 458 |
} |
|
| 459 | ||
| 460 |
# Draw shadow text first (if enabled) |
|
| 461 | 1192x |
if (shadow) {
|
| 462 |
# Convert points to user coordinate offset |
|
| 463 | 15x |
shadow_off <- shadow_offset * 0.01 # Scale for user coordinates |
| 464 | 15x |
shadow_col <- adjust_alpha(shadow_color, shadow_alpha) |
| 465 | ||
| 466 | 15x |
graphics::text( |
| 467 | 15x |
x = x + shadow_off, y = y - shadow_off, |
| 468 | 15x |
labels = label, |
| 469 | 15x |
cex = cex, |
| 470 | 15x |
col = shadow_col, |
| 471 | 15x |
font = font |
| 472 |
) |
|
| 473 |
} |
|
| 474 | ||
| 475 |
# Draw main text |
|
| 476 | 1192x |
graphics::text( |
| 477 | 1192x |
x = x, y = y, |
| 478 | 1192x |
labels = label, |
| 479 | 1192x |
cex = cex, |
| 480 | 1192x |
col = col, |
| 481 | 1192x |
font = font |
| 482 |
) |
|
| 483 |
} |
|
| 484 | ||
| 485 |
#' Get Label Position on Edge |
|
| 486 |
#' |
|
| 487 |
#' Calculates the position for an edge label (matches qgraph-style curves). |
|
| 488 |
#' For curved edges, the label is offset perpendicular to the edge to avoid |
|
| 489 |
#' overlapping with the edge line. |
|
| 490 |
#' |
|
| 491 |
#' @param x1,y1 Start point. |
|
| 492 |
#' @param x2,y2 End point. |
|
| 493 |
#' @param position Position along edge (0-1). |
|
| 494 |
#' @param curve Curvature amount. |
|
| 495 |
#' @param curvePivot Curve pivot position. |
|
| 496 |
#' @param label_offset Additional perpendicular offset for the label (in user coords). |
|
| 497 |
#' Positive values offset in the same direction as the curve bulge. |
|
| 498 |
#' Default 0.03 provides good separation from the edge line. |
|
| 499 |
#' @return List with x, y coordinates. |
|
| 500 |
#' @keywords internal |
|
| 501 |
get_edge_label_position <- function(x1, y1, x2, y2, position = 0.5, |
|
| 502 |
curve = 0, curvePivot = 0.5, |
|
| 503 |
label_offset = 0) {
|
|
| 504 |
# Edge vector and length |
|
| 505 | 1163x |
dx <- x2 - x1 |
| 506 | 1163x |
dy <- y2 - y1 |
| 507 | 1163x |
len <- sqrt(dx^2 + dy^2) |
| 508 | ||
| 509 |
# Defensive check for empty or NA values |
|
| 510 | 1163x |
if (length(len) == 0 || is.na(len) || len < 1e-10) {
|
| 511 | 2x |
return(list(x = x1, y = y1)) |
| 512 |
} |
|
| 513 | ||
| 514 |
# Perpendicular unit vector (counterclockwise rotation) |
|
| 515 | 1161x |
px <- -dy / len |
| 516 | 1161x |
py <- dx / len |
| 517 | ||
| 518 | 1161x |
if (length(curve) == 0 || is.na(curve) || abs(curve) < 1e-6) {
|
| 519 |
# Straight edge - position along line with perpendicular offset |
|
| 520 | 902x |
base_x <- x1 + position * dx |
| 521 | 902x |
base_y <- y1 + position * dy |
| 522 | ||
| 523 |
# Offset perpendicular to edge (default: above the line) |
|
| 524 | 902x |
return(list( |
| 525 | 902x |
x = base_x + label_offset * px, |
| 526 | 902x |
y = base_y + label_offset * py |
| 527 |
)) |
|
| 528 |
} |
|
| 529 | ||
| 530 |
# Curved edge - match qgraph-style curve calculation |
|
| 531 |
# Same curve offset as draw_curved_edge_base |
|
| 532 | 259x |
curve_offset <- curve * len * 0.25 |
| 533 | 259x |
min_offset <- abs(curve) * 0.15 |
| 534 | 259x |
if (abs(curve_offset) > 0 && abs(curve_offset) < min_offset) {
|
| 535 | 13x |
curve_offset <- sign(curve_offset) * min_offset |
| 536 |
} |
|
| 537 | ||
| 538 |
# Base point along edge |
|
| 539 | 259x |
t <- position |
| 540 | 259x |
bx <- x1 + t * dx |
| 541 | 259x |
by <- y1 + t * dy |
| 542 | ||
| 543 |
# Parabolic offset for curve position |
|
| 544 | 259x |
offset_factor <- 4 * t * (1 - t) |
| 545 | ||
| 546 | 259x |
if (curvePivot != 0.5) {
|
| 547 | 2x |
if (t <= curvePivot) {
|
| 548 | 1x |
offset_factor <- (t / curvePivot)^2 * 4 * curvePivot * (1 - curvePivot) |
| 549 |
} else {
|
|
| 550 | 1x |
offset_factor <- ((1 - t) / (1 - curvePivot))^2 * 4 * curvePivot * (1 - curvePivot) |
| 551 |
} |
|
| 552 |
} |
|
| 553 | ||
| 554 |
# Position on the curve |
|
| 555 | 259x |
curve_x <- bx + curve_offset * offset_factor * px |
| 556 | 259x |
curve_y <- by + curve_offset * offset_factor * py |
| 557 | ||
| 558 |
# Add additional offset in the direction of the curve bulge |
|
| 559 |
# This moves the label to the convex side of the curve |
|
| 560 | 259x |
curve_direction <- sign(curve) |
| 561 | ! |
if (curve_direction == 0) curve_direction <- 1 |
| 562 | ||
| 563 | 259x |
list( |
| 564 | 259x |
x = curve_x + label_offset * curve_direction * px, |
| 565 | 259x |
y = curve_y + label_offset * curve_direction * py |
| 566 |
) |
|
| 567 |
} |
|
| 568 | ||
| 569 |
#' Render All Edges |
|
| 570 |
#' |
|
| 571 |
#' Renders all edges in the network. |
|
| 572 |
#' |
|
| 573 |
#' @param edges Edge data frame with from, to columns. |
|
| 574 |
#' @param layout Matrix with x, y columns. |
|
| 575 |
#' @param node_sizes Vector of node sizes. |
|
| 576 |
#' @param shapes Vector of node shapes. |
|
| 577 |
#' @param edge.color Vector of edge colors. |
|
| 578 |
#' @param edge.width Vector of edge widths. |
|
| 579 |
#' @param lty Vector of line types. |
|
| 580 |
#' @param curve Vector of curvatures. |
|
| 581 |
#' @param curvePivot Vector of curve pivot positions. |
|
| 582 |
#' @param arrows Logical or vector: draw arrows? |
|
| 583 |
#' @param asize Arrow size. |
|
| 584 |
#' @param bidirectional Logical or vector: bidirectional arrows? |
|
| 585 |
#' @param loopRotation Vector of loop rotation angles. |
|
| 586 |
#' @param edge.labels Vector of edge labels or NULL. |
|
| 587 |
#' @param edge.label.cex Label size. |
|
| 588 |
#' @param edge.label.bg Label background color. |
|
| 589 |
#' @param edge.label.position Label position along edge. |
|
| 590 |
#' @keywords internal |
|
| 591 |
render_edges_base <- function(edges, layout, node_sizes, shapes = "circle", |
|
| 592 |
edge.color = "gray50", edge.width = 1, lty = 1, |
|
| 593 |
curve = 0, curvePivot = 0.5, arrows = TRUE, |
|
| 594 |
asize = 0.02, bidirectional = FALSE, |
|
| 595 |
loopRotation = NULL, edge.labels = NULL, |
|
| 596 |
edge.label.cex = 0.8, edge.label.bg = "white", |
|
| 597 |
edge.label.position = 0.5) {
|
|
| 598 | 4x |
m <- nrow(edges) |
| 599 | 1x |
if (m == 0) return(invisible()) |
| 600 | ||
| 601 | 3x |
n <- nrow(layout) |
| 602 | ||
| 603 |
# Calculate network center for inward curve direction |
|
| 604 | 3x |
center_x <- mean(layout[, 1]) |
| 605 | 3x |
center_y <- mean(layout[, 2]) |
| 606 | ||
| 607 |
# Vectorize parameters |
|
| 608 | 3x |
edge.color <- recycle_to_length(edge.color, m) |
| 609 | 3x |
edge.width <- recycle_to_length(edge.width, m) |
| 610 | 3x |
lty <- recycle_to_length(lty, m) |
| 611 | 3x |
curve <- recycle_to_length(curve, m) |
| 612 | 3x |
curvePivot <- recycle_to_length(curvePivot, m) |
| 613 | 3x |
arrows <- recycle_to_length(arrows, m) |
| 614 | 3x |
asize <- recycle_to_length(asize, m) |
| 615 | 3x |
bidirectional <- recycle_to_length(bidirectional, m) |
| 616 | 3x |
node_sizes <- recycle_to_length(node_sizes, n) |
| 617 | 3x |
shapes <- recycle_to_length(shapes, n) |
| 618 | ||
| 619 |
# Loop rotation |
|
| 620 | 3x |
if (is.null(loopRotation)) {
|
| 621 | 2x |
loopRotation <- resolve_loop_rotation(NULL, edges, layout) |
| 622 |
} else {
|
|
| 623 | 1x |
loopRotation <- recycle_to_length(loopRotation, m) |
| 624 |
} |
|
| 625 | ||
| 626 |
# Get render order (weakest to strongest) |
|
| 627 | 3x |
order_idx <- get_edge_order(edges) |
| 628 | ||
| 629 |
# Storage for label positions |
|
| 630 | 3x |
label_positions <- vector("list", m)
|
| 631 | ||
| 632 | 3x |
for (i in order_idx) {
|
| 633 | 7x |
from_idx <- edges$from[i] |
| 634 | 7x |
to_idx <- edges$to[i] |
| 635 | ||
| 636 | 7x |
x1 <- layout[from_idx, 1] |
| 637 | 7x |
y1 <- layout[from_idx, 2] |
| 638 | 7x |
x2 <- layout[to_idx, 1] |
| 639 | 7x |
y2 <- layout[to_idx, 2] |
| 640 | ||
| 641 |
# Self-loop |
|
| 642 | 7x |
if (from_idx == to_idx) {
|
| 643 | 2x |
draw_self_loop_base( |
| 644 | 2x |
x1, y1, node_sizes[from_idx], |
| 645 | 2x |
col = edge.color[i], |
| 646 | 2x |
lwd = edge.width[i], |
| 647 | 2x |
lty = lty[i], |
| 648 | 2x |
rotation = loopRotation[i], |
| 649 | 2x |
arrow = arrows[i], |
| 650 | 2x |
asize = asize[i] |
| 651 |
) |
|
| 652 | ||
| 653 |
# Label position for self-loop (at top of loop) |
|
| 654 | 2x |
loop_dist <- node_sizes[from_idx] * 2.5 |
| 655 | 2x |
label_positions[[i]] <- list( |
| 656 | 2x |
x = x1 + loop_dist * cos(loopRotation[i]), |
| 657 | 2x |
y = y1 + loop_dist * sin(loopRotation[i]) |
| 658 |
) |
|
| 659 | 2x |
next |
| 660 |
} |
|
| 661 | ||
| 662 |
# Calculate edge endpoints (offset from node centers) |
|
| 663 | 5x |
angle_to <- splot_angle(x1, y1, x2, y2) |
| 664 | 5x |
angle_from <- splot_angle(x2, y2, x1, y1) |
| 665 | ||
| 666 | 5x |
start <- cent_to_edge(x1, y1, angle_to, node_sizes[from_idx], NULL, shapes[from_idx]) |
| 667 | 5x |
end <- cent_to_edge(x2, y2, angle_from, node_sizes[to_idx], NULL, shapes[to_idx]) |
| 668 | ||
| 669 |
# Use curve value as-is (direction already calculated by caller) |
|
| 670 | 5x |
curve_i <- curve[i] |
| 671 | ||
| 672 |
# Draw edge |
|
| 673 | 5x |
if (abs(curve_i) > 1e-6) {
|
| 674 | 2x |
draw_curved_edge_base( |
| 675 | 2x |
start$x, start$y, end$x, end$y, |
| 676 | 2x |
curve = curve_i, |
| 677 | 2x |
curvePivot = curvePivot[i], |
| 678 | 2x |
col = edge.color[i], |
| 679 | 2x |
lwd = edge.width[i], |
| 680 | 2x |
lty = lty[i], |
| 681 | 2x |
arrow = arrows[i], |
| 682 | 2x |
asize = asize[i], |
| 683 | 2x |
bidirectional = bidirectional[i] |
| 684 |
) |
|
| 685 |
} else {
|
|
| 686 | 3x |
draw_straight_edge_base( |
| 687 | 3x |
start$x, start$y, end$x, end$y, |
| 688 | 3x |
col = edge.color[i], |
| 689 | 3x |
lwd = edge.width[i], |
| 690 | 3x |
lty = lty[i], |
| 691 | 3x |
arrow = arrows[i], |
| 692 | 3x |
asize = asize[i], |
| 693 | 3x |
bidirectional = bidirectional[i] |
| 694 |
) |
|
| 695 |
} |
|
| 696 | ||
| 697 |
# Store label position |
|
| 698 | 5x |
label_positions[[i]] <- get_edge_label_position( |
| 699 | 5x |
start$x, start$y, end$x, end$y, |
| 700 | 5x |
position = edge.label.position, |
| 701 | 5x |
curve = curve_i, |
| 702 | 5x |
curvePivot = curvePivot[i] |
| 703 |
) |
|
| 704 |
} |
|
| 705 | ||
| 706 |
# Draw edge labels |
|
| 707 | 3x |
if (!is.null(edge.labels)) {
|
| 708 | 2x |
edge.labels <- recycle_to_length(edge.labels, m) |
| 709 | ||
| 710 | 2x |
for (i in seq_len(m)) {
|
| 711 | 5x |
if (!is.null(edge.labels[i]) && !is.na(edge.labels[i]) && edge.labels[i] != "") {
|
| 712 | 5x |
pos <- label_positions[[i]] |
| 713 | 5x |
draw_edge_label_base( |
| 714 | 5x |
pos$x, pos$y, |
| 715 | 5x |
label = edge.labels[i], |
| 716 | 5x |
cex = edge.label.cex, |
| 717 | 5x |
col = "gray30", |
| 718 | 5x |
bg = edge.label.bg |
| 719 |
) |
|
| 720 |
} |
|
| 721 |
} |
|
| 722 |
} |
|
| 723 |
} |
| 1 |
#' @title Base R Graphics Network Plotting |
|
| 2 |
#' @description Network visualization using base R graphics (similar to qgraph). |
|
| 3 |
#' @name splot |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Plot Network with Base R Graphics |
|
| 7 |
#' |
|
| 8 |
#' Creates a network visualization using base R graphics functions (polygon, |
|
| 9 |
#' lines, xspline, etc.) instead of grid graphics. This provides better |
|
| 10 |
#' performance for large networks and uses the same snake_case parameter names |
|
| 11 |
#' as soplot() for consistency. |
|
| 12 |
#' |
|
| 13 |
#' @param x Network input. Can be: |
|
| 14 |
#' - A square numeric matrix (adjacency/weight matrix) |
|
| 15 |
#' - A data frame with edge list (from, to, optional weight columns) |
|
| 16 |
#' - An igraph object |
|
| 17 |
#' - A cograph_network object |
|
| 18 |
#' @param layout Layout algorithm: "circle", "spring", "groups", or a matrix |
|
| 19 |
#' of x,y coordinates, or an igraph layout function. Also supports igraph |
|
| 20 |
#' two-letter codes: "kk", "fr", "drl", "mds", "ni", etc. Default is "oval" |
|
| 21 |
#' @param directed Logical. Force directed interpretation. NULL for auto-detect. |
|
| 22 |
#' @param seed Random seed for deterministic layouts. Default 42. |
|
| 23 |
#' @param theme Theme name: "classic", "dark", "minimal", "colorblind", etc. |
|
| 24 |
#' |
|
| 25 |
#' @param node_size Node size(s). Single value or vector. Default 3. |
|
| 26 |
#' @param node_size2 Secondary node size for ellipse/rectangle height. |
|
| 27 |
#' @param node_shape Node shape(s): "circle", "square", "triangle", "diamond", |
|
| 28 |
#' "pentagon", "hexagon", "star", "heart", "ellipse", "cross", or any custom |
|
| 29 |
#' SVG shape registered with register_svg_shape(). |
|
| 30 |
#' @param node_svg Custom SVG for nodes: path to SVG file OR inline SVG string. |
|
| 31 |
#' @param svg_preserve_aspect Logical: maintain SVG aspect ratio? Default TRUE. |
|
| 32 |
#' @param node_fill Node fill color(s). |
|
| 33 |
#' @param node_border_color Node border color(s). |
|
| 34 |
#' @param node_border_width Node border width(s). |
|
| 35 |
#' @param node_alpha Node transparency (0-1). Default 1. |
|
| 36 |
#' @param labels Node labels: TRUE (use node names/indices), FALSE (none), |
|
| 37 |
#' or character vector. |
|
| 38 |
#' @param label_size Label character expansion factor. |
|
| 39 |
#' @param label_color Label text color. |
|
| 40 |
#' @param label_position Label position: "center", "above", "below", "left", "right". |
|
| 41 |
#' @param label_fontface Font face for labels: "plain", "bold", "italic", "bold.italic". Default "plain". |
|
| 42 |
#' @param label_fontfamily Font family for labels: "sans", "serif", "mono". Default "sans". |
|
| 43 |
#' @param label_hjust Horizontal justification (0=left, 0.5=center, 1=right). Default 0.5. |
|
| 44 |
#' @param label_vjust Vertical justification (0=bottom, 0.5=center, 1=top). Default 0.5. |
|
| 45 |
#' @param label_angle Text rotation angle in degrees. Default 0. |
|
| 46 |
#' |
|
| 47 |
#' @param pie_values List of numeric vectors for pie chart nodes. Each element |
|
| 48 |
#' corresponds to a node and contains values for pie segments. If a simple |
|
| 49 |
#' numeric vector with values between 0 and 1 is provided (e.g., centrality scores), |
|
| 50 |
#' it is automatically converted to donut_fill for convenience. |
|
| 51 |
#' @param pie_colors List of color vectors for pie segments. |
|
| 52 |
#' @param pie_border_width Border width for pie slice dividers. NULL uses node_border_width. |
|
| 53 |
#' @param donut_fill Numeric value (0-1) for donut fill proportion. This is the |
|
| 54 |
#' qgraph-style API: 0.1 = 10% filled, 0.5 = 50% filled, 1.0 = fully filled. |
|
| 55 |
#' Can be a single value (all nodes) or vector (per-node values). |
|
| 56 |
#' @param donut_values Deprecated. Use donut_fill for simple fill proportion. |
|
| 57 |
#' @param donut_color Fill color(s) for the donut ring. |
|
| 58 |
#' Single color sets fill for all nodes. |
|
| 59 |
#' Two colors set fill and background for all nodes. |
|
| 60 |
#' More than 2 colors set per-node fill colors (recycled to n_nodes). |
|
| 61 |
#' Default: "maroon" fill, "gray90" background when node_shape="donut". |
|
| 62 |
#' @param donut_colors Deprecated. Use donut_color instead. |
|
| 63 |
#' @param donut_border_color Border color for donut rings. NULL uses node_border_color. |
|
| 64 |
#' @param donut_border_width Border width for donut rings. NULL uses node_border_width. |
|
| 65 |
#' @param donut_outer_border_color Color for outer boundary border (enables double border). |
|
| 66 |
#' NULL (default) shows single border. Set to a color for double border effect. |
|
| 67 |
#' Can be scalar or per-node vector. |
|
| 68 |
#' @param donut_line_type Line type for donut borders: "solid", "dashed", "dotted", or |
|
| 69 |
#' numeric (1=solid, 2=dashed, 3=dotted). Can be scalar or per-node vector. |
|
| 70 |
#' @param donut_border_lty Deprecated. Use `donut_line_type` instead. |
|
| 71 |
#' @param donut_inner_ratio Inner radius ratio for donut (0-1). Default 0.5. |
|
| 72 |
#' @param donut_bg_color Background color for unfilled donut portion. |
|
| 73 |
#' @param donut_shape Base shape for donut: "circle", "square", "hexagon", "triangle", |
|
| 74 |
#' "diamond", "pentagon". Can be a single value or per-node vector. |
|
| 75 |
#' Default inherits from node_shape (e.g., hexagon nodes get hexagon donuts). |
|
| 76 |
#' Set explicitly to override (e.g., donut_shape = "hexagon" for hexagon donuts |
|
| 77 |
#' on all nodes regardless of node_shape). |
|
| 78 |
#' @param donut_show_value Logical: show value in donut center? Default FALSE. |
|
| 79 |
#' @param donut_value_size Font size for donut center value. |
|
| 80 |
#' @param donut_value_color Color for donut center value. |
|
| 81 |
#' @param donut_value_fontface Font face for donut center value: "plain", "bold", "italic", "bold.italic". Default "bold". |
|
| 82 |
#' @param donut_value_fontfamily Font family for donut center value: "sans", "serif", "mono". Default "sans". |
|
| 83 |
#' @param donut_value_digits Decimal places for donut center value. Default 2. |
|
| 84 |
#' @param donut_value_prefix Text before donut center value (e.g., "$"). Default "". |
|
| 85 |
#' @param donut_value_suffix Text after donut center value (e.g., "%"). Default "". |
|
| 86 |
#' @param donut_empty Logical: render empty donut rings for NA values? Default TRUE. |
|
| 87 |
#' @param donut2_values List of values for inner donut ring (for double donut). |
|
| 88 |
#' @param donut2_colors List of color vectors for inner donut ring segments. |
|
| 89 |
#' @param donut2_inner_ratio Inner radius ratio for inner donut ring. Default 0.4. |
|
| 90 |
#' |
|
| 91 |
#' @param edge_color Edge color(s). If NULL, uses edge_positive_color/edge_negative_color based on weight. |
|
| 92 |
#' @param edge_width Edge width(s). If NULL, scales by weight using edge_size and edge_width_range. |
|
| 93 |
#' @param edge_size Base edge size for weight scaling. NULL (default) uses adaptive sizing |
|
| 94 |
#' based on network size: `15 * exp(-n_nodes/90) + 1`. For directed networks, this |
|
| 95 |
#' is halved. Larger values = thicker edges overall. |
|
| 96 |
#' @param esize Deprecated. Use `edge_size` instead. |
|
| 97 |
#' @param edge_width_range Output width range as c(min, max) for weight-based scaling. |
|
| 98 |
#' Default c(0.5, 4). Edges are scaled to fit within this range. |
|
| 99 |
#' @param edge_scale_mode Scaling mode for edge weights: "linear" (default, qgraph-style), |
|
| 100 |
#' "log" (logarithmic for wide weight ranges), "sqrt" (moderate compression), |
|
| 101 |
#' or "rank" (equal visual spacing regardless of weight distribution). |
|
| 102 |
#' @param edge_cutoff Two-tier cutoff for edge width scaling. NULL (default) = auto-calculate |
|
| 103 |
#' as 75th percentile of weights (qgraph behavior). 0 = disabled (continuous scaling). |
|
| 104 |
#' Positive number = manual threshold. Edges below cutoff get minimal width variation. |
|
| 105 |
#' @param cut Deprecated. Use `edge_cutoff` instead. |
|
| 106 |
#' @param edge_alpha Edge transparency (0-1). Default 0.8. |
|
| 107 |
#' @param edge_labels Edge labels: TRUE (show weights), FALSE (none), |
|
| 108 |
#' or character vector. |
|
| 109 |
#' @param edge_label_size Edge label size. |
|
| 110 |
#' @param edge_label_color Edge label text color. |
|
| 111 |
#' @param edge_label_bg Edge label background color. |
|
| 112 |
#' @param edge_label_position Position along edge (0-1). |
|
| 113 |
#' @param edge_label_offset Perpendicular offset for edge labels (0 = on line, positive = above). |
|
| 114 |
#' @param edge_label_fontface Font face: "plain", "bold", "italic", "bold.italic". |
|
| 115 |
#' @param edge_label_shadow Logical: enable drop shadow for edge labels? Default FALSE. |
|
| 116 |
#' @param edge_label_shadow_color Color for edge label shadow. Default "gray40". |
|
| 117 |
#' @param edge_label_shadow_offset Offset distance for shadow in points. Default 0.5. |
|
| 118 |
#' @param edge_label_shadow_alpha Transparency for shadow (0-1). Default 0.5. |
|
| 119 |
#' @param edge_style Line type(s): 1=solid, 2=dashed, 3=dotted, etc. |
|
| 120 |
#' @param curvature Edge curvature. 0 for straight, positive/negative for curves. |
|
| 121 |
#' @param curve_scale Logical: auto-curve reciprocal edges? |
|
| 122 |
#' @param curve_shape Spline tension (-1 to 1). Default 0. |
|
| 123 |
#' @param curve_pivot Position along edge for curve control point (0-1). |
|
| 124 |
#' @param curves Curve mode: TRUE (default) = single edges straight, reciprocal edges |
|
| 125 |
#' curve as ellipse (two opposing curves); FALSE = all straight; "force" = all curved. |
|
| 126 |
#' @param arrow_size Arrow head size. |
|
| 127 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 128 |
#' @param show_arrows Logical or vector: show arrows on directed edges? |
|
| 129 |
#' @param bidirectional Logical or vector: show arrows at both ends? |
|
| 130 |
#' @param loop_rotation Angle(s) in radians for self-loop direction. |
|
| 131 |
#' @param edge_start_style Style for the start segment of edges: "solid" (default), |
|
| 132 |
#' "dashed", or "dotted". Use dashed/dotted to indicate edge direction (source node). |
|
| 133 |
#' @param edge_start_length Fraction of edge length for the styled start segment (0-0.5). |
|
| 134 |
#' Default 0.15 (15% of edge). Only applies when edge_start_style is not "solid". |
|
| 135 |
#' @param edge_start_dot_density Pattern for dotted start segments. A two-character string |
|
| 136 |
#' where the first digit is dot length and second is gap length (in line width units). |
|
| 137 |
#' Default "12" (1 unit dot, 2 units gap). Use "11" for tighter dots, "13" for more spacing. |
|
| 138 |
#' Only applies when edge_start_style = "dotted". |
|
| 139 |
#' |
|
| 140 |
#' @param edge_ci Numeric vector of CI widths (0-1 scale). Larger values = more uncertainty. |
|
| 141 |
#' @param edge_ci_scale Width multiplier for underlay thickness. Default 2. |
|
| 142 |
#' @param edge_ci_alpha Transparency for underlay (0-1). Default 0.15. |
|
| 143 |
#' @param edge_ci_color Underlay color. NA (default) uses main edge color. |
|
| 144 |
#' @param edge_ci_style Line type for underlay: 1=solid, 2=dashed, 3=dotted. Default 2. |
|
| 145 |
#' @param edge_ci_arrows Logical: show arrows on underlay? Default FALSE. |
|
| 146 |
#' |
|
| 147 |
#' @param edge_label_style Preset style: "none", "estimate", "full", "range", "stars". |
|
| 148 |
#' @param edge_label_template Template with placeholders: \{est\}, \{range\}, \{low\}, \{up\}, \{p\}, \{stars\}.
|
|
| 149 |
#' Overrides edge_label_style if provided. |
|
| 150 |
#' @param edge_label_digits Decimal places for estimates. Default 2. |
|
| 151 |
#' @param edge_label_oneline Logical: single line format? Default TRUE. |
|
| 152 |
#' @param edge_label_ci_format CI format: "bracket" for `[low, up]` or "dash" for `low-up`. |
|
| 153 |
#' @param edge_ci_lower Numeric vector of lower CI bounds for labels. |
|
| 154 |
#' @param edge_ci_upper Numeric vector of upper CI bounds for labels. |
|
| 155 |
#' @param edge_label_p Numeric vector of p-values for edges. |
|
| 156 |
#' @param edge_label_p_digits Decimal places for p-values. Default 3. |
|
| 157 |
#' @param edge_label_p_prefix Prefix for p-values. Default "p=". |
|
| 158 |
#' @param edge_label_stars Stars for labels: character vector, TRUE (compute from p), |
|
| 159 |
#' or numeric (treated as p-values). |
|
| 160 |
#' |
|
| 161 |
#' @param weight_digits Number of decimal places to round edge weights to before |
|
| 162 |
#' plotting. Edges that round to zero are automatically removed. Default 2. |
|
| 163 |
#' Set NULL to disable rounding. |
|
| 164 |
#' @param threshold Minimum absolute weight to display. |
|
| 165 |
#' @param minimum Alias for threshold (qgraph compatibility). Uses max of threshold and minimum. |
|
| 166 |
#' @param maximum Maximum weight for scaling. NULL for auto. |
|
| 167 |
#' @param edge_positive_color Color for positive weights. |
|
| 168 |
#' @param positive_color Deprecated. Use `edge_positive_color` instead. |
|
| 169 |
#' @param edge_negative_color Color for negative weights. |
|
| 170 |
#' @param negative_color Deprecated. Use `edge_negative_color` instead. |
|
| 171 |
#' @param edge_duplicates How to handle duplicate edges in undirected networks. |
|
| 172 |
#' NULL (default) = stop with error listing duplicates. Options: "sum", "mean", |
|
| 173 |
#' "first", "max", "min", or a custom aggregation function. |
|
| 174 |
#' |
|
| 175 |
#' @param title Plot title. |
|
| 176 |
#' @param title_size Title font size. |
|
| 177 |
#' @param margins Margins as c(bottom, left, top, right). |
|
| 178 |
#' @param background Background color. |
|
| 179 |
#' @param rescale Logical: rescale layout to -1 to 1 range? |
|
| 180 |
#' @param layout_scale Scale factor for layout. >1 expands (spreads nodes apart), |
|
| 181 |
#' <1 contracts (brings nodes closer). Use "auto" to automatically scale based |
|
| 182 |
#' on node count (compact for small networks, expanded for large). Default 1. |
|
| 183 |
#' @param layout_margin Margin around the layout as fraction of range. Default 0.15. |
|
| 184 |
#' Set to 0 for no extra margin (tighter fit). Affects white space around nodes. |
|
| 185 |
#' @param aspect Logical: maintain aspect ratio? |
|
| 186 |
#' @param use_pch Logical: use points() for simple circles (faster). Default FALSE. |
|
| 187 |
#' @param usePCH Deprecated. Use `use_pch` instead. |
|
| 188 |
#' @param scaling Scaling mode: "default" for qgraph-matched scaling where node_size=6 |
|
| 189 |
#' looks similar to qgraph vsize=6, or "legacy" to preserve pre-v2.0 behavior. |
|
| 190 |
#' |
|
| 191 |
#' @param legend Logical: show legend? |
|
| 192 |
#' @param legend_position Position: "topright", "topleft", "bottomright", "bottomleft". |
|
| 193 |
#' @param legend_size Legend text size. |
|
| 194 |
#' @param legend_edge_colors Logical: show positive/negative edge colors in legend? |
|
| 195 |
#' @param legend_node_sizes Logical: show node size scale in legend? |
|
| 196 |
#' @param groups Group assignments for node coloring/legend. |
|
| 197 |
#' @param node_names Alternative names for legend (separate from labels). |
|
| 198 |
#' |
|
| 199 |
#' @param filetype Output format: "default" (screen), "png", "pdf", "svg", "jpeg", "tiff". |
|
| 200 |
#' @param filename Output filename (without extension). |
|
| 201 |
#' @param width Output width in inches. |
|
| 202 |
#' @param height Output height in inches. |
|
| 203 |
#' @param res Resolution in DPI for raster outputs (PNG, JPEG, TIFF). Default 600. |
|
| 204 |
#' @param ... Additional arguments passed to layout functions. |
|
| 205 |
#' |
|
| 206 |
#' @details |
|
| 207 |
#' ## Edge Curve Behavior |
|
| 208 |
#' Edge curving is controlled by three parameters that interact: |
|
| 209 |
#' \describe{
|
|
| 210 |
#' \item{\strong{curves}}{Mode for automatic curving. \code{FALSE} = all straight,
|
|
| 211 |
#' \code{TRUE} (default) = curve only reciprocal edge pairs as an ellipse,
|
|
| 212 |
#' \code{"force"} = curve all edges inward toward network center.}
|
|
| 213 |
#' \item{\strong{curvature}}{Manual curvature amount (0-1 typical). Sets the
|
|
| 214 |
#' magnitude of curves. Default 0 uses automatic 0.175 for curved edges. |
|
| 215 |
#' Positive values curve edges; the direction is automatically determined. |
|
| 216 |
#' } |
|
| 217 |
#' \item{\strong{curve_scale}}{Not currently used; reserved for future scaling.}
|
|
| 218 |
#' } |
|
| 219 |
#' |
|
| 220 |
#' For reciprocal edges (A\code{->}B and B\code{->}A both exist), the edges curve
|
|
| 221 |
#' in opposite directions to form a visual ellipse, making bidirectional |
|
| 222 |
#' relationships clear. |
|
| 223 |
#' |
|
| 224 |
#' ## Weight Scaling Modes (edge_scale_mode) |
|
| 225 |
#' Controls how edge weights are mapped to visual widths: |
|
| 226 |
#' \describe{
|
|
| 227 |
#' \item{\strong{linear} (default)}{Width proportional to weight. Best when
|
|
| 228 |
#' weights are similar in magnitude.} |
|
| 229 |
#' \item{\strong{log}}{Logarithmic scaling. Best when weights span multiple
|
|
| 230 |
#' orders of magnitude (e.g., 0.01 to 100).} |
|
| 231 |
#' \item{\strong{sqrt}}{Square root scaling. Moderate compression, good for
|
|
| 232 |
#' moderately skewed distributions.} |
|
| 233 |
#' |
|
| 234 |
#' \item{\strong{rank}}{Rank-based scaling. Ignores actual values; uses relative
|
|
| 235 |
#' ordering. All edges get equal visual spacing regardless of weight distribution.} |
|
| 236 |
#' } |
|
| 237 |
#' |
|
| 238 |
#' ## Donut vs Pie vs Double Donut |
|
| 239 |
#' Three ways to show additional data on nodes: |
|
| 240 |
#' \describe{
|
|
| 241 |
#' \item{\strong{Donut (donut_fill)}}{Single ring showing a proportion (0-1).
|
|
| 242 |
#' Ideal for completion rates, probabilities, or any single metric per node. |
|
| 243 |
#' Use \code{donut_color} for fill color and \code{donut_bg_color} for unfilled portion.}
|
|
| 244 |
#' \item{\strong{Pie (pie_values)}}{Multiple colored segments showing category
|
|
| 245 |
#' breakdown. Ideal for composition data. Values are normalized to sum to 1. |
|
| 246 |
#' Use \code{pie_colors} for segment colors.}
|
|
| 247 |
#' \item{\strong{Double Donut (donut2_values)}}{Two concentric rings for comparing
|
|
| 248 |
#' two metrics per node. Outer ring uses \code{donut_fill}/\code{donut_color},
|
|
| 249 |
#' inner ring uses \code{donut2_values}/\code{donut2_colors}.}
|
|
| 250 |
#' } |
|
| 251 |
#' |
|
| 252 |
#' ## CI Underlay System |
|
| 253 |
#' Confidence interval underlays draw a wider, semi-transparent edge behind the |
|
| 254 |
#' main edge to visualize uncertainty: |
|
| 255 |
#' \describe{
|
|
| 256 |
#' \item{\strong{edge_ci}}{Vector of CI widths (0-1 scale). Larger = more uncertainty.}
|
|
| 257 |
#' \item{\strong{edge_ci_scale}}{Multiplier for underlay width relative to main edge.
|
|
| 258 |
#' Default 2 means underlay is twice as wide as main edge at CI=1.} |
|
| 259 |
#' \item{\strong{edge_ci_alpha}}{Transparency of underlay (0-1). Default 0.15.}
|
|
| 260 |
#' \item{\strong{edge_ci_style}}{Line type: 1=solid, 2=dashed (default), 3=dotted.}
|
|
| 261 |
#' } |
|
| 262 |
#' |
|
| 263 |
#' ## Edge Label Templates |
|
| 264 |
#' For statistical output, use templates to format complex labels: |
|
| 265 |
#' \describe{
|
|
| 266 |
#' \item{\strong{edge_label_template}}{Template string with placeholders:
|
|
| 267 |
#' \code{\{est\}} for estimate/weight, \code{\{low\}}/\code{\{up\}} for CI bounds,
|
|
| 268 |
#' \code{\{range\}} for formatted range, \code{\{p\}} for p-value, \code{\{stars\}}
|
|
| 269 |
#' for significance stars.} |
|
| 270 |
#' \item{\strong{edge_label_style}}{Preset styles: \code{"estimate"} (weight only),
|
|
| 271 |
#' \code{"full"} (estimate + CI), \code{"range"} (CI only), \code{"stars"} (significance).}
|
|
| 272 |
#' } |
|
| 273 |
#' |
|
| 274 |
#' @return Invisibly returns the cograph_network object. |
|
| 275 |
#' |
|
| 276 |
#' @seealso |
|
| 277 |
#' \code{\link{soplot}} for grid graphics rendering (alternative engine),
|
|
| 278 |
#' \code{\link{cograph}} for creating network objects,
|
|
| 279 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 280 |
#' \code{\link{sn_edges}} for edge customization,
|
|
| 281 |
#' \code{\link{sn_layout}} for layout algorithms,
|
|
| 282 |
#' \code{\link{sn_theme}} for visual themes,
|
|
| 283 |
#' \code{\link{from_qgraph}} and \code{\link{from_tna}} for converting external objects
|
|
| 284 |
#' |
|
| 285 |
#' @export |
|
| 286 |
#' |
|
| 287 |
#' @examples |
|
| 288 |
#' # Basic network from adjacency matrix |
|
| 289 |
#' adj <- matrix(c(0, 1, 1, 0, |
|
| 290 |
#' 0, 0, 1, 1, |
|
| 291 |
#' 0, 0, 0, 1, |
|
| 292 |
#' 0, 0, 0, 0), 4, 4, byrow = TRUE) |
|
| 293 |
#' splot(adj) |
|
| 294 |
#' |
|
| 295 |
#' # With curved edges |
|
| 296 |
#' splot(adj, curvature = 0.2) |
|
| 297 |
#' |
|
| 298 |
#' # Weighted network with colors |
|
| 299 |
#' w_adj <- matrix(c(0, 0.5, -0.3, 0, |
|
| 300 |
#' 0.8, 0, 0.4, -0.2, |
|
| 301 |
#' 0, 0, 0, 0.6, |
|
| 302 |
#' 0, 0, 0, 0), 4, 4, byrow = TRUE) |
|
| 303 |
#' splot(w_adj, edge_positive_color = "darkgreen", edge_negative_color = "red") |
|
| 304 |
#' |
|
| 305 |
#' # Pie chart nodes |
|
| 306 |
#' splot(adj, pie_values = list(c(1,2,3), c(2,2), c(1,1,1,1), c(3,1))) |
|
| 307 |
#' |
|
| 308 |
#' # Circle layout with labels |
|
| 309 |
#' splot(adj, layout = "circle", labels = c("A", "B", "C", "D"))
|
|
| 310 |
#' |
|
| 311 |
splot <- function( |
|
| 312 |
x, |
|
| 313 |
layout = "oval", |
|
| 314 |
directed = NULL, |
|
| 315 |
seed = 42, |
|
| 316 |
theme = NULL, |
|
| 317 | ||
| 318 |
# Node aesthetics |
|
| 319 |
node_size = NULL, |
|
| 320 |
node_size2 = NULL, |
|
| 321 |
node_shape = "circle", |
|
| 322 |
node_svg = NULL, |
|
| 323 |
svg_preserve_aspect = TRUE, |
|
| 324 |
node_fill = NULL, |
|
| 325 |
node_border_color = NULL, |
|
| 326 |
node_border_width = 1, |
|
| 327 |
node_alpha = 1, |
|
| 328 |
labels = TRUE, |
|
| 329 |
label_size = NULL, |
|
| 330 |
label_color = "black", |
|
| 331 |
label_position = "center", |
|
| 332 |
label_fontface = "plain", |
|
| 333 |
label_fontfamily = "sans", |
|
| 334 |
label_hjust = 0.5, |
|
| 335 |
label_vjust = 0.5, |
|
| 336 |
label_angle = 0, |
|
| 337 | ||
| 338 |
# Pie/Donut |
|
| 339 |
pie_values = NULL, |
|
| 340 |
pie_colors = NULL, |
|
| 341 |
pie_border_width = NULL, |
|
| 342 |
donut_fill = NULL, |
|
| 343 |
donut_values = NULL, |
|
| 344 |
donut_color = NULL, |
|
| 345 |
donut_colors = NULL, # Deprecated: use donut_color |
|
| 346 |
donut_border_color = NULL, |
|
| 347 |
donut_border_width = NULL, |
|
| 348 |
donut_outer_border_color = NULL, |
|
| 349 |
donut_line_type = "solid", |
|
| 350 |
donut_border_lty = NULL, # Deprecated: use donut_line_type |
|
| 351 |
donut_inner_ratio = 0.8, |
|
| 352 |
donut_bg_color = "gray90", |
|
| 353 |
donut_shape = "circle", |
|
| 354 |
donut_show_value = FALSE, |
|
| 355 |
donut_value_size = 0.8, |
|
| 356 |
donut_value_color = "black", |
|
| 357 |
donut_value_fontface = "bold", |
|
| 358 |
donut_value_fontfamily = "sans", |
|
| 359 |
donut_value_digits = 2, |
|
| 360 |
donut_value_prefix = "", |
|
| 361 |
donut_value_suffix = "", |
|
| 362 |
donut_empty = TRUE, |
|
| 363 |
donut2_values = NULL, |
|
| 364 |
donut2_colors = NULL, |
|
| 365 |
donut2_inner_ratio = 0.4, |
|
| 366 | ||
| 367 |
# Edge aesthetics |
|
| 368 |
edge_color = NULL, |
|
| 369 |
edge_width = NULL, |
|
| 370 |
edge_size = NULL, |
|
| 371 |
esize = NULL, # Deprecated: use edge_size |
|
| 372 |
edge_width_range = c(0.1, 4), |
|
| 373 |
edge_scale_mode = "linear", |
|
| 374 |
edge_cutoff = NULL, |
|
| 375 |
cut = NULL, # Deprecated: use edge_cutoff |
|
| 376 |
edge_alpha = 0.8, |
|
| 377 |
edge_labels = FALSE, |
|
| 378 |
edge_label_size = 0.8, |
|
| 379 |
edge_label_color = "gray30", |
|
| 380 |
edge_label_bg = "white", |
|
| 381 |
edge_label_position = 0.5, |
|
| 382 |
edge_label_offset = 0, |
|
| 383 |
edge_label_fontface = "plain", |
|
| 384 |
edge_label_shadow = FALSE, |
|
| 385 |
edge_label_shadow_color = "gray40", |
|
| 386 |
edge_label_shadow_offset = 0.5, |
|
| 387 |
edge_label_shadow_alpha = 0.5, |
|
| 388 |
edge_style = 1, |
|
| 389 |
curvature = 0, |
|
| 390 |
curve_scale = TRUE, |
|
| 391 |
curve_shape = 0, |
|
| 392 |
curve_pivot = 0.5, |
|
| 393 |
curves = TRUE, |
|
| 394 |
arrow_size = 1, |
|
| 395 |
arrow_angle = pi/6, |
|
| 396 |
show_arrows = TRUE, |
|
| 397 |
bidirectional = FALSE, |
|
| 398 |
loop_rotation = NULL, |
|
| 399 | ||
| 400 |
# Edge Start Style (for direction clarity) |
|
| 401 |
edge_start_style = "solid", |
|
| 402 |
edge_start_length = 0.15, |
|
| 403 |
edge_start_dot_density = "12", |
|
| 404 | ||
| 405 |
# Edge CI Underlays |
|
| 406 |
edge_ci = NULL, |
|
| 407 |
edge_ci_scale = 2.0, |
|
| 408 |
edge_ci_alpha = 0.15, |
|
| 409 |
edge_ci_color = NA, |
|
| 410 |
edge_ci_style = 2, |
|
| 411 |
edge_ci_arrows = FALSE, |
|
| 412 | ||
| 413 |
# Edge Label Templates |
|
| 414 |
edge_label_style = "none", |
|
| 415 |
edge_label_template = NULL, |
|
| 416 |
edge_label_digits = 2, |
|
| 417 |
edge_label_oneline = TRUE, |
|
| 418 |
edge_label_ci_format = "bracket", |
|
| 419 |
edge_ci_lower = NULL, |
|
| 420 |
edge_ci_upper = NULL, |
|
| 421 |
edge_label_p = NULL, |
|
| 422 |
edge_label_p_digits = 3, |
|
| 423 |
edge_label_p_prefix = "p=", |
|
| 424 |
edge_label_stars = NULL, |
|
| 425 | ||
| 426 |
# Weight handling |
|
| 427 |
weight_digits = 2, |
|
| 428 |
threshold = 0, |
|
| 429 |
minimum = 0, |
|
| 430 |
maximum = NULL, |
|
| 431 |
edge_positive_color = "#2E7D32", |
|
| 432 |
positive_color = NULL, # Deprecated: use edge_positive_color |
|
| 433 |
edge_negative_color = "#C62828", |
|
| 434 |
negative_color = NULL, # Deprecated: use edge_negative_color |
|
| 435 |
edge_duplicates = NULL, |
|
| 436 | ||
| 437 |
# Plot settings |
|
| 438 |
title = NULL, |
|
| 439 |
title_size = 1.2, |
|
| 440 |
margins = c(0.1, 0.1, 0.1, 0.1), |
|
| 441 |
background = "white", |
|
| 442 |
rescale = TRUE, |
|
| 443 |
layout_scale = 1, |
|
| 444 |
layout_margin = 0.15, |
|
| 445 |
aspect = TRUE, |
|
| 446 |
use_pch = FALSE, |
|
| 447 |
usePCH = NULL, # Deprecated: use use_pch |
|
| 448 |
scaling = "default", |
|
| 449 | ||
| 450 |
# Legend |
|
| 451 |
legend = FALSE, |
|
| 452 |
legend_position = "topright", |
|
| 453 |
legend_size = 0.8, |
|
| 454 |
legend_edge_colors = TRUE, |
|
| 455 |
legend_node_sizes = FALSE, |
|
| 456 |
groups = NULL, |
|
| 457 |
node_names = NULL, |
|
| 458 | ||
| 459 |
# Output |
|
| 460 |
filetype = "default", |
|
| 461 |
filename = "splot", |
|
| 462 |
width = 7, |
|
| 463 |
height = 7, |
|
| 464 |
res = 600, |
|
| 465 |
... |
|
| 466 |
) {
|
|
| 467 | ||
| 468 |
# ============================================ |
|
| 469 |
# 1. INPUT PROCESSING |
|
| 470 |
# ============================================ |
|
| 471 | ||
| 472 |
# Handle tna objects directly |
|
| 473 | 674x |
if (inherits(x, "tna")) {
|
| 474 | 7x |
tna_params <- from_tna(x, engine = "splot", plot = FALSE) |
| 475 |
# User-supplied args override tna defaults (only if explicitly provided) |
|
| 476 | 7x |
call_args <- tna_params |
| 477 | 7x |
user_args <- as.list(match.call(expand.dots = FALSE))[-1] |
| 478 | 7x |
user_args$x <- NULL # already set via tna_params$x |
| 479 | 7x |
dots <- list(...) |
| 480 | 7x |
for (nm in names(user_args)) {
|
| 481 | 22x |
val <- eval(user_args[[nm]], envir = parent.frame()) |
| 482 | 22x |
if (!is.null(val)) call_args[[nm]] <- val |
| 483 |
} |
|
| 484 | 7x |
for (nm in names(dots)) {
|
| 485 | ! |
call_args[[nm]] <- dots[[nm]] |
| 486 |
} |
|
| 487 | 7x |
return(do.call(splot, call_args)) |
| 488 |
} |
|
| 489 | ||
| 490 |
# ============================================ |
|
| 491 |
# HANDLE DEPRECATED PARAMETERS |
|
| 492 |
# ============================================ |
|
| 493 |
# Detect which arguments were explicitly provided by the user |
|
| 494 | 667x |
explicit_args <- names(match.call()) |
| 495 | ||
| 496 |
# For params with NULL defaults, simple check works |
|
| 497 | 667x |
edge_size <- handle_deprecated_param(edge_size, esize, "edge_size", "esize") |
| 498 | 667x |
edge_cutoff <- handle_deprecated_param(edge_cutoff, cut, "edge_cutoff", "cut") |
| 499 | ||
| 500 |
# For params with non-NULL defaults, use new_val_was_set to check if user explicitly set them |
|
| 501 | 667x |
use_pch <- handle_deprecated_param( |
| 502 | 667x |
use_pch, usePCH, "use_pch", "usePCH", |
| 503 | 667x |
new_val_was_set = "use_pch" %in% explicit_args |
| 504 |
) |
|
| 505 | 667x |
edge_positive_color <- handle_deprecated_param( |
| 506 | 667x |
edge_positive_color, positive_color, |
| 507 | 667x |
"edge_positive_color", "positive_color", |
| 508 | 667x |
new_val_was_set = "edge_positive_color" %in% explicit_args |
| 509 |
) |
|
| 510 | 667x |
edge_negative_color <- handle_deprecated_param( |
| 511 | 667x |
edge_negative_color, negative_color, |
| 512 | 667x |
"edge_negative_color", "negative_color", |
| 513 | 667x |
new_val_was_set = "edge_negative_color" %in% explicit_args |
| 514 |
) |
|
| 515 | 667x |
donut_line_type <- handle_deprecated_param( |
| 516 | 667x |
donut_line_type, donut_border_lty, |
| 517 | 667x |
"donut_line_type", "donut_border_lty", |
| 518 | 667x |
new_val_was_set = "donut_line_type" %in% explicit_args |
| 519 |
) |
|
| 520 | ||
| 521 |
# Convert edge_label_fontface to numeric if string (for backwards compat with renderers) |
|
| 522 | 667x |
edge_label_fontface_num <- fontface_to_numeric(edge_label_fontface) |
| 523 | ||
| 524 |
# Round matrix weights to filter near-zero edges globally |
|
| 525 | 667x |
if (is.matrix(x) && !is.null(weight_digits)) {
|
| 526 | 615x |
x <- round(x, weight_digits) |
| 527 |
} |
|
| 528 | ||
| 529 |
# Set seed for deterministic layouts |
|
| 530 | 667x |
if (!is.null(seed)) {
|
| 531 | 667x |
set.seed(seed) |
| 532 |
} |
|
| 533 | ||
| 534 |
# Convert to cograph_network if needed |
|
| 535 | 667x |
network <- ensure_cograph_network(x, layout = layout, seed = seed, ...) |
| 536 | ||
| 537 |
# Apply theme if specified |
|
| 538 | 667x |
if (!is.null(theme)) {
|
| 539 | 134x |
th <- get_theme(theme) |
| 540 | 134x |
if (!is.null(th)) {
|
| 541 |
# Extract theme colors |
|
| 542 | 46x |
if (is.null(node_fill)) node_fill <- th$get("node_fill")
|
| 543 | 133x |
if (is.null(node_border_color)) node_border_color <- th$get("node_border_color")
|
| 544 | ! |
if (is.null(background)) background <- th$get("background")
|
| 545 | 133x |
if (length(label_color) == 1 && label_color == "black") label_color <- th$get("label_color")
|
| 546 | 132x |
if (length(edge_positive_color) == 1 && edge_positive_color == "#2E7D32") edge_positive_color <- th$get("edge_positive_color")
|
| 547 | 132x |
if (length(edge_negative_color) == 1 && edge_negative_color == "#C62828") edge_negative_color <- th$get("edge_negative_color")
|
| 548 |
} |
|
| 549 |
} |
|
| 550 | ||
| 551 |
# Extract network data using getter functions |
|
| 552 |
# This handles all formats: new list format, old attr format, and R6 wrapper |
|
| 553 | 667x |
nodes <- get_nodes(network) |
| 554 | 667x |
edges <- get_edges(network) |
| 555 | 667x |
is_net_directed <- is_directed(network) |
| 556 | ||
| 557 |
# Get layout coordinates from nodes if available, or from layout element |
|
| 558 | 667x |
if ("x" %in% names(nodes) && !all(is.na(nodes$x))) {
|
| 559 | 667x |
layout_coords <- data.frame(x = nodes$x, y = nodes$y) |
| 560 | ! |
} else if (!is.null(network$layout)) {
|
| 561 | ! |
layout_coords <- network$layout |
| 562 | ! |
} else if (!is.null(attr(network, "layout"))) {
|
| 563 | ! |
layout_coords <- attr(network, "layout") |
| 564 | ! |
} else if (!is.null(network$network) && inherits(network$network, "CographNetwork")) {
|
| 565 | ! |
layout_coords <- network$network$get_layout() |
| 566 |
} else {
|
|
| 567 | ! |
layout_coords <- NULL |
| 568 |
} |
|
| 569 | ||
| 570 |
# (oval layout uses elliptical spacing but nodes remain circular via aspect=TRUE) |
|
| 571 | ||
| 572 | 667x |
n_nodes <- nrow(nodes) |
| 573 | 667x |
n_edges <- if (!is.null(edges)) nrow(edges) else 0 |
| 574 | ||
| 575 |
# Determine if directed |
|
| 576 | 667x |
if (is.null(directed)) {
|
| 577 | 501x |
directed <- is_net_directed |
| 578 |
} |
|
| 579 | ||
| 580 |
# Check for duplicate edges in undirected networks |
|
| 581 | 667x |
if (!directed && !is.null(edges) && nrow(edges) > 0) {
|
| 582 | 473x |
dup_check <- detect_duplicate_edges(edges) |
| 583 | 473x |
if (dup_check$has_duplicates) {
|
| 584 | 3x |
if (is.null(edge_duplicates)) {
|
| 585 |
# Build error message |
|
| 586 | 1x |
dup_msg <- vapply(dup_check$info, function(d) {
|
| 587 | 1x |
sprintf(" - Nodes %d-%d: %d edges (weights: %s)",
|
| 588 | 1x |
d$nodes[1], d$nodes[2], d$count, |
| 589 | 1x |
paste(round(d$weights, 2), collapse = ", ")) |
| 590 | 1x |
}, character(1)) |
| 591 | 1x |
stop("Found ", length(dup_check$info), " duplicate edge pair(s) in undirected network:\n",
|
| 592 | 1x |
paste(dup_msg, collapse = "\n"), "\n\n", |
| 593 | 1x |
"Specify how to handle with edge_duplicates parameter:\n", |
| 594 | 1x |
" edge_duplicates = \"sum\" # Sum weights\n", |
| 595 | 1x |
" edge_duplicates = \"mean\" # Average weights\n", |
| 596 | 1x |
" edge_duplicates = \"first\" # Keep first edge\n", |
| 597 | 1x |
" edge_duplicates = \"max\" # Keep max weight\n", |
| 598 | 1x |
" edge_duplicates = \"min\" # Keep min weight\n", |
| 599 | 1x |
call. = FALSE) |
| 600 |
} |
|
| 601 | 2x |
edges <- aggregate_duplicate_edges(edges, edge_duplicates) |
| 602 | 2x |
n_edges <- nrow(edges) |
| 603 |
# Update the network object with deduplicated edges (old format only) |
|
| 604 | 2x |
if (!is.null(network$network) && inherits(network$network, "CographNetwork")) {
|
| 605 | 1x |
network$network$set_edges(edges) |
| 606 |
} |
|
| 607 |
} |
|
| 608 |
} |
|
| 609 | ||
| 610 |
# ============================================ |
|
| 611 |
# 2. LAYOUT HANDLING |
|
| 612 |
# ============================================ |
|
| 613 | ||
| 614 | 666x |
if (is.null(layout_coords)) {
|
| 615 | ! |
stop("Layout coordinates not available", call. = FALSE)
|
| 616 |
} |
|
| 617 | ||
| 618 | 666x |
layout_mat <- as.matrix(layout_coords[, c("x", "y")])
|
| 619 | ||
| 620 |
# Rescale to [-1, 1] |
|
| 621 | 666x |
if (rescale) {
|
| 622 | 660x |
layout_mat <- as.matrix(rescale_layout(layout_mat, mar = 0.1)) |
| 623 |
} |
|
| 624 | ||
| 625 |
# Apply layout scale (expand/contract around center) |
|
| 626 |
# Handle "auto" scaling based on node count |
|
| 627 | 666x |
if (identical(layout_scale, "auto")) {
|
| 628 |
# Auto-scale formula: |
|
| 629 |
# - Small networks (<10): compact (0.8-0.9) |
|
| 630 |
# - Medium networks (10-30): normal (0.9-1.1) |
|
| 631 |
# - Large networks (>30): expanded (1.1-1.4) |
|
| 632 | 3x |
layout_scale <- 0.7 + 0.7 * (1 - exp(-n_nodes / 25)) |
| 633 |
} |
|
| 634 | ||
| 635 | 666x |
if (is.numeric(layout_scale) && layout_scale != 1) {
|
| 636 | 9x |
center <- colMeans(layout_mat) |
| 637 | 9x |
layout_mat <- t(t(layout_mat - center) * layout_scale + center) |
| 638 |
} |
|
| 639 | ||
| 640 |
# ============================================ |
|
| 641 |
# 2b. AUTO-CONVERT pie_values VECTOR TO donut_fill |
|
| 642 |
# ============================================ |
|
| 643 | ||
| 644 |
# If pie_values is a numeric vector (not list) with values in [0,1], |
|
| 645 |
# treat it as donut_fill instead (single proportion per node) |
|
| 646 | 666x |
if (!is.null(pie_values) && is.numeric(pie_values) && !is.list(pie_values)) {
|
| 647 | 1x |
if (all(pie_values >= 0 & pie_values <= 1, na.rm = TRUE)) {
|
| 648 | 1x |
donut_fill <- pie_values |
| 649 | 1x |
pie_values <- NULL |
| 650 |
} |
|
| 651 |
} |
|
| 652 | ||
| 653 |
# ============================================ |
|
| 654 |
# 3. PARAMETER VECTORIZATION |
|
| 655 |
# ============================================ |
|
| 656 | ||
| 657 |
# Get scale constants for current scaling mode |
|
| 658 | 666x |
scale <- get_scale_constants(scaling) |
| 659 | ||
| 660 |
# Node sizes (qgraph-style, using scale constants) |
|
| 661 | 666x |
vsize_usr <- resolve_node_sizes(node_size, n_nodes, scaling = scaling) |
| 662 | 666x |
vsize2_usr <- if (!is.null(node_size2)) {
|
| 663 | 1x |
resolve_node_sizes(node_size2, n_nodes, scaling = scaling) |
| 664 |
} else {
|
|
| 665 | 665x |
vsize_usr |
| 666 |
} |
|
| 667 | ||
| 668 |
# Node shapes |
|
| 669 |
# Handle custom SVG if provided |
|
| 670 | 666x |
if (!is.null(node_svg)) {
|
| 671 |
# Register SVG as a temporary shape |
|
| 672 | 2x |
temp_svg_name <- paste0("_splot_svg_", format(Sys.time(), "%H%M%S"))
|
| 673 | 2x |
tryCatch({
|
| 674 | 2x |
register_svg_shape(temp_svg_name, node_svg) |
| 675 | 1x |
node_shape <- temp_svg_name |
| 676 | 2x |
}, error = function(e) {
|
| 677 | 1x |
warning("Failed to register SVG shape: ", e$message, ". Using default shape.",
|
| 678 | 1x |
call. = FALSE) |
| 679 |
}) |
|
| 680 |
} |
|
| 681 | 666x |
shapes <- resolve_shapes(node_shape, n_nodes) |
| 682 | ||
| 683 |
# Node colors |
|
| 684 | 666x |
node_colors <- resolve_node_colors(node_fill, n_nodes, nodes, groups) |
| 685 | ||
| 686 |
# Vectorize node_alpha |
|
| 687 | 666x |
node_alphas <- recycle_to_length(node_alpha, n_nodes) |
| 688 | ||
| 689 |
# Apply alpha to node colors (vectorized) |
|
| 690 | 666x |
node_colors <- mapply(function(col, alpha) {
|
| 691 | 2658x |
if (alpha < 1) adjust_alpha(col, alpha) else col |
| 692 | 666x |
}, node_colors, node_alphas, SIMPLIFY = TRUE, USE.NAMES = FALSE) |
| 693 | ||
| 694 |
# Border colors |
|
| 695 | 666x |
if (is.null(node_border_color)) {
|
| 696 | 662x |
node_border_color <- sapply(node_colors, function(c) {
|
| 697 | 2661x |
tryCatch(adjust_brightness(c, -0.3), error = function(e) "black") |
| 698 |
}) |
|
| 699 |
} |
|
| 700 | 666x |
border_colors <- recycle_to_length(node_border_color, n_nodes) |
| 701 | ||
| 702 |
# Border widths |
|
| 703 | 666x |
border_widths <- recycle_to_length(node_border_width, n_nodes) |
| 704 | ||
| 705 |
# Labels |
|
| 706 | 666x |
node_labels <- resolve_labels(labels, nodes, n_nodes) |
| 707 | ||
| 708 |
# Label sizes (using new decoupled system) |
|
| 709 | 666x |
label_cex <- resolve_label_sizes(label_size, vsize_usr, n_nodes, scaling = scaling) |
| 710 | 666x |
label_colors <- recycle_to_length(label_color, n_nodes) |
| 711 | ||
| 712 |
# ============================================ |
|
| 713 |
# 4. EDGE PROCESSING |
|
| 714 |
# ============================================ |
|
| 715 | ||
| 716 |
# Use minimum threshold or explicit threshold |
|
| 717 | 666x |
effective_threshold <- max(threshold, minimum) |
| 718 | ||
| 719 | 666x |
if (n_edges > 0) {
|
| 720 |
# Filter by minimum weight (threshold) |
|
| 721 | 653x |
orig_n_edges <- n_edges |
| 722 | 653x |
orig_weights <- edges$weight |
| 723 | 653x |
edges <- filter_edges_by_weight(edges, effective_threshold) |
| 724 | 653x |
n_edges <- nrow(edges) |
| 725 | ||
| 726 |
# Subset edge_labels to match filtered edges |
|
| 727 | 653x |
if (n_edges < orig_n_edges && is.character(edge_labels) && length(edge_labels) == orig_n_edges) {
|
| 728 | 1x |
keep_idx <- which(abs(orig_weights) >= effective_threshold) |
| 729 | 1x |
edge_labels <- edge_labels[keep_idx] |
| 730 |
} |
|
| 731 |
} |
|
| 732 | ||
| 733 |
# ============================================ |
|
| 734 |
# EDGE CURVING BEHAVIOR |
|
| 735 |
# ============================================ |
|
| 736 |
# curves = TRUE (default): single edges straight, reciprocal edges curved |
|
| 737 |
# curves = "force": all edges curved |
|
| 738 |
# curves = FALSE: all edges straight |
|
| 739 |
# |
|
| 740 |
# NOTE: We no longer duplicate edges for undirected networks. |
|
| 741 |
# Only edges with actual reciprocal pairs (A→B AND B→A) will curve. |
|
| 742 | ||
| 743 | 666x |
if (n_edges > 0) {
|
| 744 |
# Edge colors |
|
| 745 | 653x |
edge_colors <- resolve_edge_colors(edges, edge_color, edge_positive_color, edge_negative_color) |
| 746 | ||
| 747 |
# Vectorize edge_alpha and apply to edge colors |
|
| 748 | 653x |
edge_alphas <- recycle_to_length(edge_alpha, n_edges) |
| 749 | 653x |
edge_colors <- mapply(function(col, alpha) {
|
| 750 | 3x |
if (alpha < 1) adjust_alpha(col, alpha) else col |
| 751 | 653x |
}, edge_colors, edge_alphas, SIMPLIFY = TRUE, USE.NAMES = FALSE) |
| 752 | ||
| 753 |
# Apply edge_cutoff threshold for transparency: edges below cutoff are faded |
|
| 754 | 653x |
if (!is.null(edge_cutoff) && edge_cutoff > 0 && "weight" %in% names(edges)) {
|
| 755 | 3x |
abs_weights <- abs(edges$weight) |
| 756 | 3x |
below_cutoff <- abs_weights < edge_cutoff |
| 757 | 3x |
if (any(below_cutoff)) {
|
| 758 |
# Scale alpha: edges at 0 get 20% of normal alpha, edges near cutoff get full alpha |
|
| 759 | 1x |
fade_factor <- ifelse(below_cutoff, 0.2 + 0.8 * (abs_weights / edge_cutoff), 1) |
| 760 | 1x |
edge_colors <- mapply(function(col, fade) {
|
| 761 | 4x |
if (fade < 1) adjust_alpha(col, fade) else col |
| 762 | 1x |
}, edge_colors, fade_factor, SIMPLIFY = TRUE, USE.NAMES = FALSE) |
| 763 |
} |
|
| 764 |
} |
|
| 765 | ||
| 766 |
# Edge widths |
|
| 767 | 653x |
edge_widths <- resolve_edge_widths( |
| 768 | 653x |
edges = edges, |
| 769 | 653x |
edge.width = edge_width, |
| 770 | 653x |
esize = edge_size, |
| 771 | 653x |
n_nodes = n_nodes, |
| 772 | 653x |
directed = directed, |
| 773 | 653x |
maximum = maximum, |
| 774 | 653x |
minimum = threshold, |
| 775 | 653x |
cut = edge_cutoff, |
| 776 | 653x |
edge_width_range = edge_width_range, |
| 777 | 653x |
edge_scale_mode = edge_scale_mode, |
| 778 | 653x |
scaling = scaling |
| 779 |
) |
|
| 780 | ||
| 781 |
# Line types - convert string values to numeric |
|
| 782 | 653x |
edge_styles_raw <- recycle_to_length(edge_style, n_edges) |
| 783 | 653x |
ltys <- sapply(edge_styles_raw, function(s) {
|
| 784 | 2816x |
if (is.character(s)) {
|
| 785 | 34x |
switch(s, |
| 786 | 10x |
"solid" = 1, |
| 787 | 8x |
"dashed" = 2, |
| 788 | 2x |
"dotted" = 3, |
| 789 | 3x |
"dotdash" = 4, |
| 790 | 5x |
"longdash" = 5, |
| 791 | 3x |
"twodash" = 6, |
| 792 | 3x |
1 # default |
| 793 |
) |
|
| 794 |
} else {
|
|
| 795 | 2782x |
s |
| 796 |
} |
|
| 797 |
}) |
|
| 798 | ||
| 799 |
# Adjust line widths for dotted style (reduce by 30% to avoid overly thick appearance) |
|
| 800 | 653x |
for (i in seq_along(ltys)) {
|
| 801 | 2816x |
if (ltys[i] == 3) { # dotted
|
| 802 | 5x |
edge_widths[i] <- edge_widths[i] * 0.7 |
| 803 |
} |
|
| 804 |
} |
|
| 805 | ||
| 806 |
# Handle curves mode: |
|
| 807 |
# FALSE = all straight |
|
| 808 |
# TRUE or "mutual" = only reciprocal edges curved (opposite directions) |
|
| 809 |
# "force" = all edges curved (reciprocals opposite, singles inward) |
|
| 810 |
# |
|
| 811 |
# curvature parameter sets the MAGNITUDE of curves (default 0.25) |
|
| 812 |
# curves parameter controls WHICH edges get curved |
|
| 813 | 653x |
is_reciprocal <- rep(FALSE, n_edges) |
| 814 | ||
| 815 |
# Identify reciprocal pairs |
|
| 816 | 653x |
for (i in seq_len(n_edges)) {
|
| 817 | 2816x |
from_i <- edges$from[i] |
| 818 | 2816x |
to_i <- edges$to[i] |
| 819 | 44x |
if (from_i == to_i) next |
| 820 | 2772x |
for (j in seq_len(n_edges)) {
|
| 821 | 19117x |
if (j != i && edges$from[j] == to_i && edges$to[j] == from_i) {
|
| 822 | 424x |
is_reciprocal[i] <- TRUE |
| 823 | 424x |
break |
| 824 |
} |
|
| 825 |
} |
|
| 826 |
} |
|
| 827 | ||
| 828 |
# Curve magnitude (user-specified or default 0.25) |
|
| 829 | 653x |
curve_magnitude <- if (curvature == 0) 0.175 else abs(curvature) |
| 830 | ||
| 831 |
# Initialize curves vector to 0 (straight) |
|
| 832 | 653x |
curves_vec <- rep(0, n_edges) |
| 833 | ||
| 834 |
# Calculate network center for curve direction |
|
| 835 | 653x |
center_x <- mean(layout_mat[, 1]) |
| 836 | 653x |
center_y <- mean(layout_mat[, 2]) |
| 837 | ||
| 838 | 653x |
if (identical(curves, TRUE) || identical(curves, "mutual")) {
|
| 839 |
# Curve reciprocal edges in opposite directions. |
|
| 840 |
# Use canonical ordering (lower node index first) so both edges in a pair |
|
| 841 |
# compute the same perpendicular reference, then assign opposite signs. |
|
| 842 | 644x |
for (i in seq_len(n_edges)) {
|
| 843 | 2773x |
if (is_reciprocal[i]) {
|
| 844 | 398x |
from_idx <- edges$from[i] |
| 845 | 398x |
to_idx <- edges$to[i] |
| 846 | ||
| 847 |
# Canonical direction: always compute perp from lower-index to higher-index node |
|
| 848 | 398x |
lo <- min(from_idx, to_idx) |
| 849 | 398x |
hi <- max(from_idx, to_idx) |
| 850 | 398x |
dx_canon <- layout_mat[hi, 1] - layout_mat[lo, 1] |
| 851 | 398x |
dy_canon <- layout_mat[hi, 2] - layout_mat[lo, 2] |
| 852 | ||
| 853 |
# Perpendicular vector (consistent for both edges in the pair) |
|
| 854 | 398x |
perp_x <- -dy_canon |
| 855 | 398x |
perp_y <- dx_canon |
| 856 | ||
| 857 |
# Check if positive perp moves outward from center |
|
| 858 | 398x |
mid_x <- (layout_mat[from_idx, 1] + layout_mat[to_idx, 1]) / 2 |
| 859 | 398x |
mid_y <- (layout_mat[from_idx, 2] + layout_mat[to_idx, 2]) / 2 |
| 860 | 398x |
test_x <- mid_x + perp_x * 0.1 |
| 861 | 398x |
test_y <- mid_y + perp_y * 0.1 |
| 862 | 398x |
dist_to_center_pos <- sqrt((test_x - center_x)^2 + (test_y - center_y)^2) |
| 863 | 398x |
dist_to_center_orig <- sqrt((mid_x - center_x)^2 + (mid_y - center_y)^2) |
| 864 | 398x |
outward_sign <- if (dist_to_center_pos > dist_to_center_orig) 1 else -1 |
| 865 | ||
| 866 |
# Both edges get the same sign. The renderer computes perp from the |
|
| 867 |
# edge's own from->to direction, which flips for hi->lo vs lo->hi. |
|
| 868 |
# Same sign + flipped perp = opposite curve directions. |
|
| 869 | 398x |
curves_vec[i] <- outward_sign * curve_magnitude |
| 870 |
} |
|
| 871 |
} |
|
| 872 | 9x |
} else if (identical(curves, "force")) {
|
| 873 |
# Curve all edges with the specified magnitude |
|
| 874 | 5x |
for (i in seq_len(n_edges)) {
|
| 875 | 1x |
if (edges$from[i] == edges$to[i]) next # Skip self-loops |
| 876 | 26x |
curves_vec[i] <- curve_magnitude |
| 877 |
} |
|
| 878 |
} |
|
| 879 |
# If curves = FALSE, curves_vec stays at 0 (straight edges) |
|
| 880 | ||
| 881 | 653x |
curve_pivots <- recycle_to_length(curve_pivot, n_edges) |
| 882 | 653x |
curve_shapes <- recycle_to_length(curve_shape, n_edges) |
| 883 | ||
| 884 |
# Arrows |
|
| 885 | 653x |
if (is.logical(show_arrows) && length(show_arrows) == 1) {
|
| 886 | 652x |
arrows_vec <- rep(directed && show_arrows, n_edges) |
| 887 |
} else {
|
|
| 888 | 1x |
arrows_vec <- recycle_to_length(show_arrows, n_edges) |
| 889 |
} |
|
| 890 | ||
| 891 |
# Arrow size (using scale constants for consistency) |
|
| 892 | 653x |
asize_scaled <- arrow_size * scale$arrow_factor |
| 893 | 653x |
arrow_sizes <- recycle_to_length(asize_scaled, n_edges) |
| 894 | ||
| 895 |
# Bidirectional |
|
| 896 | 653x |
bidirectionals <- recycle_to_length(bidirectional, n_edges) |
| 897 | ||
| 898 |
# Loop rotation |
|
| 899 | 653x |
loop_rotations <- resolve_loop_rotation(loop_rotation, edges, layout_mat) |
| 900 | ||
| 901 |
# Edge labels - check for template system first |
|
| 902 | 653x |
if (!is.null(edge_label_template) || edge_label_style != "none") {
|
| 903 |
# Use template-based labels |
|
| 904 | 2x |
edge_weights <- if ("weight" %in% names(edges)) edges$weight else NULL
|
| 905 | 2x |
edge_labels_vec <- build_edge_labels_from_template( |
| 906 | 2x |
template = edge_label_template, |
| 907 | 2x |
style = edge_label_style, |
| 908 | 2x |
weights = edge_weights, |
| 909 | 2x |
ci_lower = edge_ci_lower, |
| 910 | 2x |
ci_upper = edge_ci_upper, |
| 911 | 2x |
p_values = edge_label_p, |
| 912 | 2x |
stars = edge_label_stars, |
| 913 | 2x |
digits = edge_label_digits, |
| 914 | 2x |
p_digits = edge_label_p_digits, |
| 915 | 2x |
p_prefix = edge_label_p_prefix, |
| 916 | 2x |
ci_format = edge_label_ci_format, |
| 917 | 2x |
oneline = edge_label_oneline, |
| 918 | 2x |
n = n_edges |
| 919 |
) |
|
| 920 |
} else {
|
|
| 921 |
# Use standard edge labels |
|
| 922 | 651x |
edge_labels_vec <- resolve_edge_labels(edge_labels, edges, n_edges) |
| 923 |
} |
|
| 924 | ||
| 925 |
# CI underlay parameters |
|
| 926 | 653x |
edge_ci_vec <- if (!is.null(edge_ci)) recycle_to_length(edge_ci, n_edges) else NULL |
| 927 | 653x |
edge_ci_colors <- if (!is.null(edge_ci_vec)) {
|
| 928 | 9x |
if (is.na(edge_ci_color)) {
|
| 929 |
# Use main edge colors |
|
| 930 | 6x |
edge_colors |
| 931 |
} else {
|
|
| 932 | 3x |
recycle_to_length(edge_ci_color, n_edges) |
| 933 |
} |
|
| 934 | 653x |
} else NULL |
| 935 |
} |
|
| 936 | ||
| 937 |
# ============================================ |
|
| 938 |
# 5. DEVICE SETUP |
|
| 939 |
# ============================================ |
|
| 940 | ||
| 941 |
# Handle file output |
|
| 942 | 666x |
if (filetype != "default") {
|
| 943 | 12x |
full_filename <- paste0(filename, ".", filetype) |
| 944 | ||
| 945 | 12x |
if (filetype == "png") {
|
| 946 | 3x |
grDevices::png(full_filename, width = width, height = height, |
| 947 | 3x |
units = "in", res = res) |
| 948 | 9x |
} else if (filetype == "pdf") {
|
| 949 | 3x |
grDevices::pdf(full_filename, width = width, height = height) |
| 950 | 6x |
} else if (filetype == "svg") {
|
| 951 | ! |
grDevices::svg(full_filename, width = width, height = height) |
| 952 | 6x |
} else if (filetype == "jpeg" || filetype == "jpg") {
|
| 953 | 4x |
grDevices::jpeg(full_filename, width = width, height = height, |
| 954 | 4x |
units = "in", res = res, quality = 100) |
| 955 | 2x |
} else if (filetype == "tiff") {
|
| 956 | 1x |
grDevices::tiff(full_filename, width = width, height = height, |
| 957 | 1x |
units = "in", res = res, compression = "lzw") |
| 958 |
} else {
|
|
| 959 | 1x |
stop("Unknown filetype: ", filetype, call. = FALSE)
|
| 960 |
} |
|
| 961 | ||
| 962 | 11x |
on.exit(grDevices::dev.off(), add = TRUE) |
| 963 |
} |
|
| 964 | ||
| 965 |
# Set up plot area - only save/restore parameters we modify |
|
| 966 | 665x |
old_mar <- graphics::par("mar")
|
| 967 | 665x |
on.exit(graphics::par(mar = old_mar), add = TRUE) |
| 968 | ||
| 969 |
# Margins - ensure title has adequate space |
|
| 970 |
# Default margins[3] (top) is 0.1 which is too small for titles |
|
| 971 |
# Add extra space proportional to title_size when title is provided |
|
| 972 | 665x |
title_space <- if (!is.null(title)) max(1.5, title_size * 1.2) else 0 |
| 973 | 665x |
graphics::par(mar = c(margins[1], margins[2], margins[3] + title_space, margins[4])) |
| 974 | ||
| 975 |
# Calculate plot limits |
|
| 976 | 665x |
x_range <- range(layout_mat[, 1], na.rm = TRUE) |
| 977 | 665x |
y_range <- range(layout_mat[, 2], na.rm = TRUE) |
| 978 | ||
| 979 |
# Add margin to limits (configurable via layout_margin parameter) |
|
| 980 | 665x |
x_margin <- diff(x_range) * layout_margin |
| 981 | 665x |
y_margin <- diff(y_range) * layout_margin |
| 982 | ||
| 983 | 665x |
xlim <- c(x_range[1] - x_margin, x_range[2] + x_margin) |
| 984 | 665x |
ylim <- c(y_range[1] - y_margin, y_range[2] + y_margin) |
| 985 | ||
| 986 |
# Create plot |
|
| 987 | 665x |
graphics::plot( |
| 988 | 665x |
1, type = "n", |
| 989 | 665x |
xlim = xlim, |
| 990 | 665x |
ylim = ylim, |
| 991 | 665x |
axes = FALSE, |
| 992 | 665x |
ann = FALSE, |
| 993 | 665x |
asp = if (aspect) 1 else NA, |
| 994 | 665x |
xaxs = "i", yaxs = "i" |
| 995 |
) |
|
| 996 | ||
| 997 |
# Background |
|
| 998 | 664x |
if (!is.null(background) && background != "transparent") {
|
| 999 | 661x |
graphics::rect( |
| 1000 | 661x |
xleft = xlim[1] - 1, ybottom = ylim[1] - 1, |
| 1001 | 661x |
xright = xlim[2] + 1, ytop = ylim[2] + 1, |
| 1002 | 661x |
col = background, border = NA |
| 1003 |
) |
|
| 1004 |
} |
|
| 1005 | ||
| 1006 |
# Title |
|
| 1007 | 664x |
if (!is.null(title)) {
|
| 1008 | 7x |
graphics::title(main = title, cex.main = title_size) |
| 1009 |
} |
|
| 1010 | ||
| 1011 |
# ============================================ |
|
| 1012 |
# 6. RENDER EDGES |
|
| 1013 |
# ============================================ |
|
| 1014 | ||
| 1015 | 664x |
if (n_edges > 0) {
|
| 1016 | 651x |
render_edges_splot( |
| 1017 | 651x |
edges = edges, |
| 1018 | 651x |
layout = layout_mat, |
| 1019 | 651x |
node_sizes = vsize_usr, |
| 1020 | 651x |
shapes = shapes, |
| 1021 | 651x |
edge_color = edge_colors, |
| 1022 | 651x |
edge_width = edge_widths, |
| 1023 | 651x |
edge_style = ltys, |
| 1024 | 651x |
curvature = curves_vec, |
| 1025 | 651x |
curve_shape = curve_shapes, |
| 1026 | 651x |
curve_pivot = curve_pivots, |
| 1027 | 651x |
show_arrows = arrows_vec, |
| 1028 | 651x |
arrow_size = arrow_sizes, |
| 1029 | 651x |
arrow_angle = arrow_angle, |
| 1030 | 651x |
bidirectional = bidirectionals, |
| 1031 | 651x |
loop_rotation = loop_rotations, |
| 1032 | 651x |
edge_labels = edge_labels_vec, |
| 1033 | 651x |
edge_label_size = edge_label_size, |
| 1034 | 651x |
edge_label_color = edge_label_color, |
| 1035 | 651x |
edge_label_bg = edge_label_bg, |
| 1036 | 651x |
edge_label_position = edge_label_position, |
| 1037 | 651x |
edge_label_offset = edge_label_offset, |
| 1038 | 651x |
edge_label_fontface = edge_label_fontface, |
| 1039 | 651x |
edge_label_shadow = edge_label_shadow, |
| 1040 | 651x |
edge_label_shadow_color = edge_label_shadow_color, |
| 1041 | 651x |
edge_label_shadow_offset = edge_label_shadow_offset, |
| 1042 | 651x |
edge_label_shadow_alpha = edge_label_shadow_alpha, |
| 1043 |
# CI underlay parameters |
|
| 1044 | 651x |
edge_ci = edge_ci_vec, |
| 1045 | 651x |
edge_ci_scale = edge_ci_scale, |
| 1046 | 651x |
edge_ci_alpha = edge_ci_alpha, |
| 1047 | 651x |
edge_ci_color = edge_ci_colors, |
| 1048 | 651x |
edge_ci_style = edge_ci_style, |
| 1049 | 651x |
edge_ci_arrows = edge_ci_arrows, |
| 1050 | 651x |
is_reciprocal = is_reciprocal, |
| 1051 |
# Edge start style parameters |
|
| 1052 | 651x |
edge_start_style = edge_start_style, |
| 1053 | 651x |
edge_start_length = edge_start_length, |
| 1054 | 651x |
edge_start_dot_density = edge_start_dot_density |
| 1055 |
) |
|
| 1056 |
} |
|
| 1057 | ||
| 1058 |
# ============================================ |
|
| 1059 |
# 7. RENDER NODES |
|
| 1060 |
# ============================================ |
|
| 1061 | ||
| 1062 |
# Auto-enable donut fill when node_shape is "donut" but no fill specified |
|
| 1063 | 663x |
if (is.null(donut_fill) && is.null(donut_values)) {
|
| 1064 | 587x |
if (any(shapes == "donut")) {
|
| 1065 |
# Create per-node fill: 1.0 for donut nodes, NA for others |
|
| 1066 | 5x |
donut_fill <- ifelse(shapes == "donut", 1.0, NA) |
| 1067 |
} |
|
| 1068 |
} |
|
| 1069 | ||
| 1070 |
# Handle donut_fill: convert to list format if provided |
|
| 1071 |
# donut_fill takes precedence over donut_values for the new simplified API |
|
| 1072 | 663x |
effective_donut_values <- donut_values |
| 1073 | 663x |
if (!is.null(donut_fill)) {
|
| 1074 |
# Convert donut_fill to list format for internal use |
|
| 1075 | 56x |
if (!is.list(donut_fill)) {
|
| 1076 | 49x |
fill_vec <- recycle_to_length(donut_fill, n_nodes) |
| 1077 | 49x |
effective_donut_values <- as.list(fill_vec) |
| 1078 |
} else {
|
|
| 1079 | 7x |
effective_donut_values <- donut_fill |
| 1080 |
} |
|
| 1081 |
} |
|
| 1082 | ||
| 1083 |
# When donut_empty = TRUE, replace NA values with 0 so empty rings still render |
|
| 1084 | 663x |
if (donut_empty && !is.null(effective_donut_values)) {
|
| 1085 | 72x |
for (di in seq_along(effective_donut_values)) {
|
| 1086 | 217x |
if (length(effective_donut_values[[di]]) == 1 && is.na(effective_donut_values[[di]])) {
|
| 1087 | 4x |
effective_donut_values[[di]] <- 0 |
| 1088 |
} |
|
| 1089 |
} |
|
| 1090 |
} |
|
| 1091 | ||
| 1092 |
# Handle donut_color (new simplified API) and donut_colors (deprecated) |
|
| 1093 |
# Priority: donut_color > donut_colors |
|
| 1094 | 663x |
effective_donut_colors <- NULL |
| 1095 | 663x |
effective_bg_color <- donut_bg_color |
| 1096 | ||
| 1097 | 663x |
if (!is.null(donut_color)) {
|
| 1098 | 11x |
if (is.list(donut_color) && length(donut_color) == 2 * n_nodes) {
|
| 1099 |
# List with 2×n_nodes: per-node (fill, bg) pairs - extract odd indices for fill |
|
| 1100 | 1x |
effective_donut_colors <- as.list(donut_color[seq(1, 2 * n_nodes, by = 2)]) |
| 1101 | 10x |
} else if (length(donut_color) == 2) {
|
| 1102 |
# Two colors: fill + background for ALL nodes |
|
| 1103 | 1x |
effective_donut_colors <- as.list(rep(donut_color[1], n_nodes)) |
| 1104 | 1x |
effective_bg_color <- donut_color[2] |
| 1105 | 9x |
} else if (length(donut_color) == 1) {
|
| 1106 |
# Single color: fill for all nodes |
|
| 1107 | 4x |
effective_donut_colors <- as.list(rep(donut_color, n_nodes)) |
| 1108 |
} else {
|
|
| 1109 |
# Multiple colors (not 2): treat as per-node fill colors |
|
| 1110 | 5x |
cols <- recycle_to_length(donut_color, n_nodes) |
| 1111 | 5x |
effective_donut_colors <- as.list(cols) |
| 1112 |
} |
|
| 1113 | 652x |
} else if (!is.null(donut_colors)) {
|
| 1114 |
# Deprecated: use old donut_colors parameter |
|
| 1115 | 3x |
effective_donut_colors <- donut_colors |
| 1116 | 649x |
} else if (any(shapes == "donut") || !is.null(effective_donut_values)) {
|
| 1117 |
# Default fill color: light gray when donuts are being used |
|
| 1118 | 67x |
effective_donut_colors <- as.list(rep("maroon", n_nodes))
|
| 1119 |
} |
|
| 1120 | ||
| 1121 |
# Determine effective donut shapes - inherit from node_shape by default |
|
| 1122 |
# If donut_shape is NULL or "circle" (default), inherit from node_shape |
|
| 1123 |
# Otherwise, use the explicitly set donut_shape |
|
| 1124 | 663x |
valid_donut_base_shapes <- c("circle", "square", "hexagon", "triangle", "diamond", "pentagon")
|
| 1125 | 663x |
if (is.null(donut_shape) || identical(donut_shape, "circle")) {
|
| 1126 |
# Inherit from node_shape, but only if it's a valid donut base shape |
|
| 1127 |
# donut, donut_pie, double_donut_pie and custom SVG shapes default to "circle" |
|
| 1128 | 653x |
special_donut_shapes <- c("donut", "donut_pie", "double_donut_pie")
|
| 1129 | 653x |
effective_donut_shapes <- ifelse( |
| 1130 | 653x |
shapes %in% valid_donut_base_shapes, |
| 1131 | 653x |
shapes, |
| 1132 | 653x |
"circle" # Default for SVG shapes and special shapes |
| 1133 |
) |
|
| 1134 |
} else {
|
|
| 1135 |
# User explicitly set donut_shape - vectorize and use it |
|
| 1136 | 10x |
effective_donut_shapes <- recycle_to_length(donut_shape, n_nodes) |
| 1137 |
} |
|
| 1138 | ||
| 1139 |
# Vectorize donut_border_color for per-node support |
|
| 1140 | 663x |
effective_donut_border_color <- if (!is.null(donut_border_color)) {
|
| 1141 | 3x |
recycle_to_length(donut_border_color, n_nodes) |
| 1142 |
} else {
|
|
| 1143 | 660x |
NULL |
| 1144 |
} |
|
| 1145 | ||
| 1146 |
# Vectorize donut_outer_border_color for per-node support (double border feature) |
|
| 1147 | 663x |
effective_donut_outer_border_color <- if (!is.null(donut_outer_border_color)) {
|
| 1148 | 3x |
recycle_to_length(donut_outer_border_color, n_nodes) |
| 1149 |
} else {
|
|
| 1150 | 660x |
NULL |
| 1151 |
} |
|
| 1152 | ||
| 1153 |
# Vectorize donut_line_type for per-node support |
|
| 1154 | 663x |
effective_donut_line_type <- recycle_to_length(donut_line_type, n_nodes) |
| 1155 | ||
| 1156 | 663x |
render_nodes_splot( |
| 1157 | 663x |
layout = layout_mat, |
| 1158 | 663x |
node_size = vsize_usr, |
| 1159 | 663x |
node_size2 = vsize2_usr, |
| 1160 | 663x |
node_shape = shapes, |
| 1161 | 663x |
node_fill = node_colors, |
| 1162 | 663x |
node_border_color = border_colors, |
| 1163 | 663x |
node_border_width = border_widths, |
| 1164 | 663x |
pie_values = pie_values, |
| 1165 | 663x |
pie_colors = pie_colors, |
| 1166 | 663x |
pie_border_width = pie_border_width, |
| 1167 | 663x |
donut_values = effective_donut_values, |
| 1168 | 663x |
donut_colors = effective_donut_colors, |
| 1169 | 663x |
donut_border_color = effective_donut_border_color, |
| 1170 | 663x |
donut_border_width = donut_border_width, |
| 1171 | 663x |
donut_outer_border_color = effective_donut_outer_border_color, |
| 1172 | 663x |
donut_line_type = effective_donut_line_type, |
| 1173 | 663x |
donut_inner_ratio = donut_inner_ratio, |
| 1174 | 663x |
donut_bg_color = effective_bg_color, |
| 1175 | 663x |
donut_shape = effective_donut_shapes, |
| 1176 | 663x |
donut_show_value = donut_show_value, |
| 1177 | 663x |
donut_value_size = donut_value_size, |
| 1178 | 663x |
donut_value_color = donut_value_color, |
| 1179 | 663x |
donut_value_fontface = donut_value_fontface, |
| 1180 | 663x |
donut_value_fontfamily = donut_value_fontfamily, |
| 1181 | 663x |
donut_value_digits = donut_value_digits, |
| 1182 | 663x |
donut_value_prefix = donut_value_prefix, |
| 1183 | 663x |
donut_value_suffix = donut_value_suffix, |
| 1184 | 663x |
donut2_values = donut2_values, |
| 1185 | 663x |
donut2_colors = donut2_colors, |
| 1186 | 663x |
donut2_inner_ratio = donut2_inner_ratio, |
| 1187 | 663x |
labels = node_labels, |
| 1188 | 663x |
label_size = label_cex, |
| 1189 | 663x |
label_color = label_colors, |
| 1190 | 663x |
label_position = label_position, |
| 1191 | 663x |
label_fontface = label_fontface, |
| 1192 | 663x |
label_fontfamily = label_fontfamily, |
| 1193 | 663x |
label_hjust = label_hjust, |
| 1194 | 663x |
label_vjust = label_vjust, |
| 1195 | 663x |
label_angle = label_angle, |
| 1196 | 663x |
use_pch = use_pch |
| 1197 |
) |
|
| 1198 | ||
| 1199 |
# ============================================ |
|
| 1200 |
# 8. LEGEND |
|
| 1201 |
# ============================================ |
|
| 1202 | ||
| 1203 | 663x |
if (legend) {
|
| 1204 |
# Determine if we have positive/negative weighted edges |
|
| 1205 | 18x |
has_pos_edges <- FALSE |
| 1206 | 18x |
has_neg_edges <- FALSE |
| 1207 | 18x |
if (n_edges > 0 && "weight" %in% names(edges)) {
|
| 1208 | 18x |
has_pos_edges <- any(edges$weight > 0, na.rm = TRUE) |
| 1209 | 18x |
has_neg_edges <- any(edges$weight < 0, na.rm = TRUE) |
| 1210 |
} |
|
| 1211 | ||
| 1212 | 18x |
render_legend_splot( |
| 1213 | 18x |
groups = groups, |
| 1214 | 18x |
node_names = node_names, |
| 1215 | 18x |
nodes = nodes, |
| 1216 | 18x |
node_colors = node_colors, |
| 1217 | 18x |
position = legend_position, |
| 1218 | 18x |
cex = legend_size, |
| 1219 | 18x |
show_edge_colors = legend_edge_colors, |
| 1220 | 18x |
positive_color = edge_positive_color, |
| 1221 | 18x |
negative_color = edge_negative_color, |
| 1222 | 18x |
has_pos_edges = has_pos_edges, |
| 1223 | 18x |
has_neg_edges = has_neg_edges, |
| 1224 | 18x |
show_node_sizes = legend_node_sizes, |
| 1225 | 18x |
node_size = vsize_usr |
| 1226 |
) |
|
| 1227 |
} |
|
| 1228 | ||
| 1229 |
# ============================================ |
|
| 1230 |
# 9. RETURN |
|
| 1231 |
# ============================================ |
|
| 1232 | ||
| 1233 | 663x |
invisible(network) |
| 1234 |
} |
|
| 1235 | ||
| 1236 | ||
| 1237 |
#' Render Edges for splot |
|
| 1238 |
#' @keywords internal |
|
| 1239 |
render_edges_splot <- function(edges, layout, node_sizes, shapes, |
|
| 1240 |
edge_color, edge_width, edge_style, curvature, |
|
| 1241 |
curve_shape, curve_pivot, show_arrows, arrow_size, |
|
| 1242 |
arrow_angle = pi/6, bidirectional, loop_rotation, edge_labels, |
|
| 1243 |
edge_label_size, edge_label_color, edge_label_bg, |
|
| 1244 |
edge_label_position, edge_label_offset = 0, |
|
| 1245 |
edge_label_fontface, |
|
| 1246 |
edge_label_shadow = FALSE, edge_label_shadow_color = "gray40", |
|
| 1247 |
edge_label_shadow_offset = 0.5, edge_label_shadow_alpha = 0.5, |
|
| 1248 |
edge_ci = NULL, edge_ci_scale = 2.0, |
|
| 1249 |
edge_ci_alpha = 0.15, edge_ci_color = NULL, |
|
| 1250 |
edge_ci_style = 2, edge_ci_arrows = FALSE, |
|
| 1251 |
is_reciprocal = NULL, |
|
| 1252 |
edge_start_style = "solid", edge_start_length = 0.15, |
|
| 1253 |
edge_start_dot_density = "12") {
|
|
| 1254 | ||
| 1255 | 657x |
m <- nrow(edges) |
| 1256 | 1x |
if (m == 0) return(invisible()) |
| 1257 | ||
| 1258 | 656x |
n <- nrow(layout) |
| 1259 | ||
| 1260 |
# Calculate network center for inward curve direction |
|
| 1261 | 656x |
center_x <- mean(layout[, 1]) |
| 1262 | 656x |
center_y <- mean(layout[, 2]) |
| 1263 | ||
| 1264 |
# Get render order (weakest to strongest) |
|
| 1265 | 656x |
order_idx <- get_edge_order(edges) |
| 1266 | ||
| 1267 |
# Storage for label positions |
|
| 1268 | 656x |
label_positions <- vector("list", m)
|
| 1269 | ||
| 1270 |
# Validate and convert edge_start_style to lty value |
|
| 1271 | ||
| 1272 |
# Accepts string values ("solid", "dashed", "dotted") or numeric (1, 2, 3)
|
|
| 1273 | 656x |
if (is.numeric(edge_start_style)) {
|
| 1274 | 3x |
if (!edge_start_style %in% c(1, 2, 3)) {
|
| 1275 | 1x |
warning("edge_start_style numeric value should be 1 (solid), 2 (dashed), or 3 (dotted). ",
|
| 1276 | 1x |
"Got: ", edge_start_style, ". Using solid.", call. = FALSE) |
| 1277 | 1x |
start_lty <- 1 |
| 1278 | 2x |
} else if (edge_start_style == 3) {
|
| 1279 |
# Dotted: use custom density pattern |
|
| 1280 | 1x |
start_lty <- edge_start_dot_density |
| 1281 |
} else {
|
|
| 1282 | 1x |
start_lty <- edge_start_style |
| 1283 |
} |
|
| 1284 |
} else {
|
|
| 1285 | 653x |
valid_styles <- c("solid", "dashed", "dotted")
|
| 1286 | 653x |
if (!edge_start_style %in% valid_styles) {
|
| 1287 | 1x |
stop("edge_start_style must be one of: ", paste(valid_styles, collapse = ", "),
|
| 1288 | 1x |
", or numeric 1-3. Got: '", edge_start_style, "'", call. = FALSE) |
| 1289 |
} |
|
| 1290 | 652x |
start_lty <- switch(edge_start_style, |
| 1291 | 652x |
"solid" = 1, |
| 1292 | 652x |
"dashed" = 2, |
| 1293 | 652x |
"dotted" = edge_start_dot_density # Use custom density pattern |
| 1294 |
) |
|
| 1295 |
} |
|
| 1296 | 655x |
start_fraction <- if (identical(start_lty, 1) || identical(start_lty, 1L)) 0 else edge_start_length |
| 1297 | ||
| 1298 |
# Helper function to calculate curve direction (bend INWARD toward center) |
|
| 1299 | 655x |
calc_curve_direction <- function(curve_val, start_x, start_y, end_x, end_y) {
|
| 1300 | 2345x |
if (length(curve_val) == 0 || is.na(curve_val)) {
|
| 1301 | 1x |
return(0) |
| 1302 |
} |
|
| 1303 | ||
| 1304 | 2344x |
if (curve_val > 1e-6) {
|
| 1305 | 11x |
mid_x <- (start_x + end_x) / 2 |
| 1306 | 11x |
mid_y <- (start_y + end_y) / 2 |
| 1307 | 11x |
dx <- end_x - start_x |
| 1308 | 11x |
dy <- end_y - start_y |
| 1309 | 11x |
to_center_x <- center_x - mid_x |
| 1310 | 11x |
to_center_y <- center_y - mid_y |
| 1311 | ||
| 1312 |
# Perpendicular to edge direction (same as draw_curved_edge_base) |
|
| 1313 |
# Clockwise rotation: (dx, dy) -> (dy, -dx) |
|
| 1314 | 11x |
len <- sqrt(dx^2 + dy^2) |
| 1315 | 1x |
if (length(len) == 0 || is.na(len) || len < 1e-10) return(curve_val) |
| 1316 | 10x |
px <- dy / len |
| 1317 | 10x |
py <- -dx / len |
| 1318 | ||
| 1319 |
# Dot product: positive = perpendicular points toward center |
|
| 1320 | 10x |
dot <- px * to_center_x + py * to_center_y |
| 1321 | ||
| 1322 | 4x |
if (dot < 0) -abs(curve_val) else abs(curve_val) |
| 1323 |
} else {
|
|
| 1324 | 2333x |
curve_val |
| 1325 |
} |
|
| 1326 |
} |
|
| 1327 | ||
| 1328 | 655x |
for (i in order_idx) {
|
| 1329 | 2814x |
from_idx <- edges$from[i] |
| 1330 | 2814x |
to_idx <- edges$to[i] |
| 1331 | ||
| 1332 |
# Skip invalid edges (NA or out-of-bounds indices) |
|
| 1333 | 2814x |
if (length(from_idx) == 0 || length(to_idx) == 0 || |
| 1334 | 2814x |
is.na(from_idx) || is.na(to_idx) || |
| 1335 | 2814x |
from_idx < 1 || to_idx < 1 || |
| 1336 | 2814x |
from_idx > n || to_idx > n) {
|
| 1337 | 2x |
next |
| 1338 |
} |
|
| 1339 | ||
| 1340 | 2812x |
x1 <- layout[from_idx, 1] |
| 1341 | 2812x |
y1 <- layout[from_idx, 2] |
| 1342 | 2812x |
x2 <- layout[to_idx, 1] |
| 1343 | 2812x |
y2 <- layout[to_idx, 2] |
| 1344 | ||
| 1345 |
# Skip if coordinates are invalid |
|
| 1346 | 2812x |
if (length(x1) == 0 || length(y1) == 0 || |
| 1347 | 2812x |
length(x2) == 0 || length(y2) == 0 || |
| 1348 | 2812x |
any(is.na(c(x1, y1, x2, y2)))) {
|
| 1349 | 3x |
next |
| 1350 |
} |
|
| 1351 | ||
| 1352 |
# Self-loop |
|
| 1353 | 2809x |
if (from_idx == to_idx) {
|
| 1354 |
# PASS 1: Draw CI underlay for self-loop (if edge_ci provided) |
|
| 1355 | 44x |
if (!is.null(edge_ci) && !is.na(edge_ci[i]) && edge_ci[i] > 0) {
|
| 1356 | 1x |
underlay_width <- edge_width[i] * (1 + edge_ci[i] * edge_ci_scale) |
| 1357 | 1x |
underlay_col <- if (!is.null(edge_ci_color)) edge_ci_color[i] else edge_color[i] |
| 1358 | 1x |
underlay_col <- adjust_alpha(underlay_col, edge_ci_alpha) |
| 1359 | ||
| 1360 | 1x |
draw_self_loop_base( |
| 1361 | 1x |
x1, y1, node_sizes[from_idx], |
| 1362 | 1x |
col = underlay_col, |
| 1363 | 1x |
lwd = underlay_width, |
| 1364 | 1x |
lty = edge_ci_style, |
| 1365 | 1x |
rotation = loop_rotation[i], |
| 1366 | 1x |
arrow = edge_ci_arrows, |
| 1367 | 1x |
asize = arrow_size[i], |
| 1368 | 1x |
arrow_angle = arrow_angle |
| 1369 |
) |
|
| 1370 |
} |
|
| 1371 | ||
| 1372 |
# PASS 2: Draw main self-loop |
|
| 1373 | 44x |
draw_self_loop_base( |
| 1374 | 44x |
x1, y1, node_sizes[from_idx], |
| 1375 | 44x |
col = edge_color[i], |
| 1376 | 44x |
lwd = edge_width[i], |
| 1377 | 44x |
lty = edge_style[i], |
| 1378 | 44x |
rotation = loop_rotation[i], |
| 1379 | 44x |
arrow = show_arrows[i], |
| 1380 | 44x |
asize = arrow_size[i], |
| 1381 | 44x |
arrow_angle = arrow_angle |
| 1382 |
) |
|
| 1383 | ||
| 1384 |
# Label position for self-loop |
|
| 1385 | 44x |
loop_dist <- node_sizes[from_idx] * 2.5 |
| 1386 | 44x |
label_positions[[i]] <- list( |
| 1387 | 44x |
x = x1 + loop_dist * cos(loop_rotation[i]), |
| 1388 | 44x |
y = y1 + loop_dist * sin(loop_rotation[i]) |
| 1389 |
) |
|
| 1390 | 44x |
next |
| 1391 |
} |
|
| 1392 | ||
| 1393 |
# Calculate edge endpoints |
|
| 1394 | 2765x |
angle_to <- splot_angle(x1, y1, x2, y2) |
| 1395 | 2765x |
angle_from <- splot_angle(x2, y2, x1, y1) |
| 1396 | ||
| 1397 | 2765x |
start <- cent_to_edge(x1, y1, angle_to, node_sizes[from_idx], NULL, shapes[from_idx]) |
| 1398 | 2765x |
end <- cent_to_edge(x2, y2, angle_from, node_sizes[to_idx], NULL, shapes[to_idx]) |
| 1399 | ||
| 1400 |
# Determine curve direction |
|
| 1401 |
# For reciprocal edges, use pre-computed curvature directly (preserves opposite directions) |
|
| 1402 |
# For non-reciprocal edges, apply inward curve direction adjustment |
|
| 1403 | 2765x |
if (!is.null(is_reciprocal) && is_reciprocal[i]) {
|
| 1404 | 420x |
curve_i <- curvature[i] |
| 1405 |
} else {
|
|
| 1406 | 2345x |
curve_i <- calc_curve_direction(curvature[i], start$x, start$y, end$x, end$y) |
| 1407 |
} |
|
| 1408 | ||
| 1409 |
# PASS 1: Draw CI underlay (if edge_ci provided) |
|
| 1410 | 2765x |
if (!is.null(edge_ci) && !is.na(edge_ci[i]) && edge_ci[i] > 0) {
|
| 1411 | 23x |
underlay_width <- edge_width[i] * (1 + edge_ci[i] * edge_ci_scale) |
| 1412 | 23x |
underlay_col <- if (!is.null(edge_ci_color)) edge_ci_color[i] else edge_color[i] |
| 1413 | 23x |
underlay_col <- adjust_alpha(underlay_col, edge_ci_alpha) |
| 1414 | ||
| 1415 | 23x |
if (abs(curve_i) > 1e-6) {
|
| 1416 | 4x |
draw_curved_edge_base( |
| 1417 | 4x |
start$x, start$y, end$x, end$y, |
| 1418 | 4x |
curve = curve_i, |
| 1419 | 4x |
curvePivot = curve_pivot[i], |
| 1420 | 4x |
col = underlay_col, |
| 1421 | 4x |
lwd = underlay_width, |
| 1422 | 4x |
lty = edge_ci_style, |
| 1423 | 4x |
arrow = edge_ci_arrows, |
| 1424 | 4x |
asize = arrow_size[i], |
| 1425 | 4x |
bidirectional = FALSE, |
| 1426 | 4x |
arrow_angle = arrow_angle |
| 1427 |
) |
|
| 1428 |
} else {
|
|
| 1429 | 19x |
draw_straight_edge_base( |
| 1430 | 19x |
start$x, start$y, end$x, end$y, |
| 1431 | 19x |
col = underlay_col, |
| 1432 | 19x |
lwd = underlay_width, |
| 1433 | 19x |
lty = edge_ci_style, |
| 1434 | 19x |
arrow = edge_ci_arrows, |
| 1435 | 19x |
asize = arrow_size[i], |
| 1436 | 19x |
bidirectional = FALSE, |
| 1437 | 19x |
arrow_angle = arrow_angle |
| 1438 |
) |
|
| 1439 |
} |
|
| 1440 |
} |
|
| 1441 | ||
| 1442 |
# PASS 2: Draw main edge |
|
| 1443 | 2765x |
if (abs(curve_i) > 1e-6) {
|
| 1444 | 423x |
draw_curved_edge_base( |
| 1445 | 423x |
start$x, start$y, end$x, end$y, |
| 1446 | 423x |
curve = curve_i, |
| 1447 | 423x |
curvePivot = curve_pivot[i], |
| 1448 | 423x |
col = edge_color[i], |
| 1449 | 423x |
lwd = edge_width[i], |
| 1450 | 423x |
lty = edge_style[i], |
| 1451 | 423x |
arrow = show_arrows[i], |
| 1452 | 423x |
asize = arrow_size[i], |
| 1453 | 423x |
bidirectional = bidirectional[i], |
| 1454 | 423x |
start_lty = start_lty, |
| 1455 | 423x |
start_fraction = start_fraction, |
| 1456 | 423x |
arrow_angle = arrow_angle |
| 1457 |
) |
|
| 1458 |
} else {
|
|
| 1459 | 2342x |
draw_straight_edge_base( |
| 1460 | 2342x |
start$x, start$y, end$x, end$y, |
| 1461 | 2342x |
col = edge_color[i], |
| 1462 | 2342x |
lwd = edge_width[i], |
| 1463 | 2342x |
lty = edge_style[i], |
| 1464 | 2342x |
arrow = show_arrows[i], |
| 1465 | 2342x |
asize = arrow_size[i], |
| 1466 | 2342x |
bidirectional = bidirectional[i], |
| 1467 | 2342x |
start_lty = start_lty, |
| 1468 | 2342x |
start_fraction = start_fraction, |
| 1469 | 2342x |
arrow_angle = arrow_angle |
| 1470 |
) |
|
| 1471 |
} |
|
| 1472 | ||
| 1473 |
# Store edge start/end and curve info for label positioning |
|
| 1474 | 2765x |
label_positions[[i]] <- list( |
| 1475 | 2765x |
start_x = start$x, start_y = start$y, |
| 1476 | 2765x |
end_x = end$x, end_y = end$y, |
| 1477 | 2765x |
curve = curve_i, |
| 1478 | 2765x |
curvePivot = curve_pivot[i] |
| 1479 |
) |
|
| 1480 |
} |
|
| 1481 | ||
| 1482 |
# Draw edge labels |
|
| 1483 | 655x |
if (!is.null(edge_labels)) {
|
| 1484 |
# Vectorize edge label parameters (strict: length 1 or m) |
|
| 1485 | 147x |
edge_label_sizes <- expand_param(edge_label_size, m, "edge_label_size") |
| 1486 | 147x |
edge_label_colors <- expand_param(edge_label_color, m, "edge_label_color") |
| 1487 | 147x |
edge_label_bgs <- expand_param(edge_label_bg, m, "edge_label_bg") |
| 1488 | 147x |
edge_label_positions_vec <- expand_param(edge_label_position, m, "edge_label_position") |
| 1489 | 147x |
edge_label_offsets <- expand_param(edge_label_offset, m, "edge_label_offset") |
| 1490 | 147x |
edge_label_shadows <- expand_param(edge_label_shadow, m, "edge_label_shadow") |
| 1491 | 147x |
edge_label_shadow_colors <- expand_param(edge_label_shadow_color, m, "edge_label_shadow_color") |
| 1492 | 147x |
edge_label_shadow_offsets <- expand_param(edge_label_shadow_offset, m, "edge_label_shadow_offset") |
| 1493 | 147x |
edge_label_shadow_alphas <- expand_param(edge_label_shadow_alpha, m, "edge_label_shadow_alpha") |
| 1494 | ||
| 1495 |
# Handle edge_label_fontface - convert strings to numbers if needed |
|
| 1496 | 147x |
edge_label_fontfaces <- expand_param(edge_label_fontface, m, "edge_label_fontface") |
| 1497 | 147x |
edge_label_fontfaces <- sapply(edge_label_fontfaces, function(ff) {
|
| 1498 | 1184x |
if (is.character(ff)) {
|
| 1499 | 1181x |
switch(ff, |
| 1500 | 1166x |
"plain" = 1, |
| 1501 | 6x |
"bold" = 2, |
| 1502 | 3x |
"italic" = 3, |
| 1503 | 3x |
"bold.italic" = 4, |
| 1504 | 3x |
1 # default |
| 1505 |
) |
|
| 1506 |
} else {
|
|
| 1507 | 3x |
ff |
| 1508 |
} |
|
| 1509 |
}) |
|
| 1510 | ||
| 1511 | 147x |
for (i in seq_len(m)) {
|
| 1512 | 1184x |
if (!is.null(edge_labels[i]) && !is.na(edge_labels[i]) && edge_labels[i] != "") {
|
| 1513 | 1180x |
edge_info <- label_positions[[i]] |
| 1514 |
# Self-loops have x, y directly; regular edges have start_x, start_y, etc. |
|
| 1515 | 1180x |
if (!is.null(edge_info$x) && !is.null(edge_info$y)) {
|
| 1516 |
# Self-loop: use stored position directly |
|
| 1517 | 39x |
pos <- list(x = edge_info$x, y = edge_info$y) |
| 1518 |
} else {
|
|
| 1519 |
# Regular edge: compute position |
|
| 1520 | 1141x |
pos <- get_edge_label_position( |
| 1521 | 1141x |
edge_info$start_x, edge_info$start_y, |
| 1522 | 1141x |
edge_info$end_x, edge_info$end_y, |
| 1523 | 1141x |
position = edge_label_positions_vec[i], |
| 1524 | 1141x |
curve = edge_info$curve, |
| 1525 | 1141x |
curvePivot = edge_info$curvePivot, |
| 1526 | 1141x |
label_offset = edge_label_offsets[i] |
| 1527 |
) |
|
| 1528 |
} |
|
| 1529 | 1180x |
draw_edge_label_base( |
| 1530 | 1180x |
pos$x, pos$y, |
| 1531 | 1180x |
label = edge_labels[i], |
| 1532 | 1180x |
cex = edge_label_sizes[i], |
| 1533 | 1180x |
col = edge_label_colors[i], |
| 1534 | 1180x |
bg = edge_label_bgs[i], |
| 1535 | 1180x |
font = edge_label_fontfaces[i], |
| 1536 | 1180x |
shadow = edge_label_shadows[i], |
| 1537 | 1180x |
shadow_color = edge_label_shadow_colors[i], |
| 1538 | 1180x |
shadow_offset = edge_label_shadow_offsets[i], |
| 1539 | 1180x |
shadow_alpha = edge_label_shadow_alphas[i] |
| 1540 |
) |
|
| 1541 |
} |
|
| 1542 |
} |
|
| 1543 |
} |
|
| 1544 |
} |
|
| 1545 | ||
| 1546 | ||
| 1547 |
#' Render Nodes for splot |
|
| 1548 |
#' |
|
| 1549 |
#' @param donut_values List of values for donut chart. Each element is a single |
|
| 1550 |
#' numeric (0-1) representing fill proportion for that node. |
|
| 1551 |
#' @keywords internal |
|
| 1552 |
render_nodes_splot <- function(layout, node_size, node_size2, node_shape, node_fill, |
|
| 1553 |
node_border_color, node_border_width, pie_values, pie_colors, |
|
| 1554 |
pie_border_width, donut_values, donut_colors, |
|
| 1555 |
donut_border_color, donut_border_width, |
|
| 1556 |
donut_outer_border_color = NULL, donut_line_type = "solid", |
|
| 1557 |
donut_inner_ratio, donut_bg_color, donut_shape, |
|
| 1558 |
donut_show_value, donut_value_size, donut_value_color, |
|
| 1559 |
donut_value_fontface = "bold", donut_value_fontfamily = "sans", |
|
| 1560 |
donut_value_digits = 2, donut_value_prefix = "", |
|
| 1561 |
donut_value_suffix = "", |
|
| 1562 |
donut2_values, donut2_colors, donut2_inner_ratio, |
|
| 1563 |
labels, label_size, label_color, label_position, |
|
| 1564 |
label_fontface = "plain", label_fontfamily = "sans", |
|
| 1565 |
label_hjust = 0.5, label_vjust = 0.5, label_angle = 0, |
|
| 1566 |
use_pch = FALSE) {
|
|
| 1567 | ||
| 1568 | 664x |
n <- nrow(layout) |
| 1569 | 1x |
if (n == 0) return(invisible()) |
| 1570 | ||
| 1571 |
# Vectorize donut parameters (strict: length 1 or n) |
|
| 1572 | 663x |
donut_inner_ratios <- expand_param(donut_inner_ratio, n, "donut_inner_ratio") |
| 1573 | 663x |
donut_bg_colors <- expand_param(donut_bg_color, n, "donut_bg_color") |
| 1574 | 663x |
donut_show_values <- expand_param(donut_show_value, n, "donut_show_value") |
| 1575 | 663x |
donut_value_sizes <- expand_param(donut_value_size, n, "donut_value_size") |
| 1576 | 663x |
donut_value_colors <- expand_param(donut_value_color, n, "donut_value_color") |
| 1577 | 663x |
donut_value_fontfaces <- expand_param(donut_value_fontface, n, "donut_value_fontface") |
| 1578 | 663x |
donut_value_fontfamilies <- expand_param(donut_value_fontfamily, n, "donut_value_fontfamily") |
| 1579 | ||
| 1580 |
# Render order: largest to smallest |
|
| 1581 | 663x |
order_idx <- get_node_order(node_size) |
| 1582 | ||
| 1583 | 663x |
for (i in order_idx) {
|
| 1584 | 2663x |
x <- layout[i, 1] |
| 1585 | 2663x |
y <- layout[i, 2] |
| 1586 | ||
| 1587 |
# Check for pie/donut/donut2 |
|
| 1588 | 2663x |
has_pie <- !is.null(pie_values) && length(pie_values) >= i && !is.null(pie_values[[i]]) && length(pie_values[[i]]) > 0 |
| 1589 |
# Check for donut: either node_shape is "donut" OR donut_values has a valid (non-NA) value |
|
| 1590 | 2663x |
has_donut <- (node_shape[i] == "donut") || |
| 1591 | 2663x |
(!is.null(donut_values) && length(donut_values) >= i && |
| 1592 | 2663x |
!is.null(donut_values[[i]]) && length(donut_values[[i]]) > 0 && !anyNA(donut_values[[i]])) |
| 1593 | 2663x |
has_donut2 <- !is.null(donut2_values) && length(donut2_values) >= i && !is.null(donut2_values[[i]]) |
| 1594 | ||
| 1595 | 2663x |
if (has_donut2 || (has_donut && has_pie)) {
|
| 1596 |
# Double donut with optional inner pie |
|
| 1597 |
# Or single donut with pie - both use the layered drawing approach |
|
| 1598 | 29x |
if (has_donut2) {
|
| 1599 |
# Double donut case |
|
| 1600 | 15x |
donut_vals <- if (has_donut) donut_values[[i]] else NULL |
| 1601 | 15x |
donut_cols <- if (!is.null(donut_colors) && length(donut_colors) >= i) donut_colors[[i]] else NULL |
| 1602 | 15x |
donut2_vals <- donut2_values[[i]] |
| 1603 | 15x |
donut2_cols <- if (!is.null(donut2_colors) && length(donut2_colors) >= i) donut2_colors[[i]] else NULL |
| 1604 | 15x |
pie_vals <- if (has_pie) pie_values[[i]] else NULL |
| 1605 | 15x |
pie_cols <- if (!is.null(pie_colors) && length(pie_colors) >= i) pie_colors[[i]] else NULL |
| 1606 | ||
| 1607 | 15x |
draw_double_donut_pie_node_base( |
| 1608 | 15x |
x, y, node_size[i], |
| 1609 | 15x |
donut_values = donut_vals, |
| 1610 | 15x |
donut_colors = donut_cols, |
| 1611 | 15x |
donut2_values = donut2_vals, |
| 1612 | 15x |
donut2_colors = donut2_cols, |
| 1613 | 15x |
pie_values = pie_vals, |
| 1614 | 15x |
pie_colors = pie_cols, |
| 1615 | 15x |
pie_default_color = node_fill[i], |
| 1616 | 15x |
outer_inner_ratio = donut_inner_ratios[i], |
| 1617 | 15x |
inner_inner_ratio = donut2_inner_ratio, |
| 1618 | 15x |
bg_color = donut_bg_colors[i], |
| 1619 | 15x |
border.col = node_border_color[i], |
| 1620 | 15x |
border.width = node_border_width[i], |
| 1621 | 15x |
pie_border.width = pie_border_width, |
| 1622 | 15x |
donut_border.width = donut_border_width |
| 1623 |
) |
|
| 1624 |
} else {
|
|
| 1625 |
# Single donut with pie |
|
| 1626 | 14x |
donut_val <- if (length(donut_values[[i]]) == 1) donut_values[[i]] else 1 |
| 1627 | 14x |
donut_col <- if (!is.null(donut_colors) && length(donut_colors) >= i) donut_colors[[i]][1] else node_fill[i] |
| 1628 | 14x |
pie_vals <- pie_values[[i]] |
| 1629 | 14x |
pie_cols <- if (!is.null(pie_colors) && length(pie_colors) >= i) pie_colors[[i]] else NULL |
| 1630 | ||
| 1631 | 14x |
draw_donut_pie_node_base( |
| 1632 | 14x |
x, y, node_size[i], |
| 1633 | 14x |
donut_value = donut_val, |
| 1634 | 14x |
donut_color = donut_col, |
| 1635 | 14x |
pie_values = pie_vals, |
| 1636 | 14x |
pie_colors = pie_cols, |
| 1637 | 14x |
pie_default_color = node_fill[i], |
| 1638 | 14x |
inner_ratio = donut_inner_ratios[i], |
| 1639 | 14x |
bg_color = donut_bg_colors[i], |
| 1640 | 14x |
border.col = node_border_color[i], |
| 1641 | 14x |
border.width = node_border_width[i], |
| 1642 | 14x |
pie_border.width = pie_border_width, |
| 1643 | 14x |
donut_border.width = donut_border_width |
| 1644 |
) |
|
| 1645 |
} |
|
| 1646 | ||
| 1647 | 2634x |
} else if (has_donut) {
|
| 1648 |
# Donut only |
|
| 1649 |
# Get donut value, defaulting to 1.0 if node_shape is "donut" but no explicit value |
|
| 1650 | 196x |
donut_vals <- if (!is.null(donut_values) && length(donut_values) >= i && |
| 1651 | 196x |
!is.null(donut_values[[i]]) && length(donut_values[[i]]) > 0 && !anyNA(donut_values[[i]])) {
|
| 1652 | 194x |
donut_values[[i]] |
| 1653 |
} else {
|
|
| 1654 | 2x |
1.0 # Default to full ring when node_shape is "donut" but no explicit value |
| 1655 |
} |
|
| 1656 | 196x |
donut_cols <- if (!is.null(donut_colors) && length(donut_colors) >= i) donut_colors[[i]] else NULL |
| 1657 | ||
| 1658 |
# Get per-node donut shape (donut_shape is now a vector) |
|
| 1659 | 196x |
current_donut_shape <- if (length(donut_shape) >= i) donut_shape[i] else "circle" |
| 1660 | ||
| 1661 |
# Determine effective donut border color (use donut_border_color[i] if set, else node_border_color) |
|
| 1662 | 196x |
effective_donut_border_col <- if (!is.null(donut_border_color) && length(donut_border_color) >= i) {
|
| 1663 | 9x |
donut_border_color[i] |
| 1664 |
} else {
|
|
| 1665 | 187x |
node_border_color[i] |
| 1666 |
} |
|
| 1667 | ||
| 1668 |
# Get per-node outer border color (for double border feature) |
|
| 1669 | 196x |
effective_outer_border_col <- if (!is.null(donut_outer_border_color) && length(donut_outer_border_color) >= i) {
|
| 1670 | 9x |
donut_outer_border_color[i] |
| 1671 |
} else {
|
|
| 1672 | 187x |
NULL |
| 1673 |
} |
|
| 1674 | ||
| 1675 |
# Get per-node border line type |
|
| 1676 | 196x |
effective_border_lty <- if (length(donut_line_type) >= i) donut_line_type[i] else "solid" |
| 1677 | ||
| 1678 | 196x |
if (current_donut_shape != "circle") {
|
| 1679 |
# Use polygon donut for non-circular shapes |
|
| 1680 | 30x |
draw_polygon_donut_node_base( |
| 1681 | 30x |
x, y, node_size[i], |
| 1682 | 30x |
values = donut_vals, |
| 1683 | 30x |
colors = donut_cols, |
| 1684 | 30x |
default_color = node_fill[i], |
| 1685 | 30x |
inner_ratio = donut_inner_ratios[i], |
| 1686 | 30x |
bg_color = donut_bg_colors[i], |
| 1687 | 30x |
center_color = node_fill[i], |
| 1688 | 30x |
donut_shape = current_donut_shape, |
| 1689 | 30x |
border.col = effective_donut_border_col, |
| 1690 | 30x |
border.width = node_border_width[i], |
| 1691 | 30x |
donut_border.width = donut_border_width, |
| 1692 | 30x |
outer_border.col = effective_outer_border_col, |
| 1693 | 30x |
border.lty = effective_border_lty, |
| 1694 | 30x |
show_value = donut_show_values[i], |
| 1695 | 30x |
value_cex = donut_value_sizes[i], |
| 1696 | 30x |
value_col = donut_value_colors[i], |
| 1697 | 30x |
value_fontface = donut_value_fontfaces[i], |
| 1698 | 30x |
value_fontfamily = donut_value_fontfamilies[i], |
| 1699 | 30x |
value_digits = donut_value_digits, |
| 1700 | 30x |
value_prefix = donut_value_prefix, |
| 1701 | 30x |
value_suffix = donut_value_suffix |
| 1702 |
) |
|
| 1703 |
} else {
|
|
| 1704 |
# Use circular donut (default) |
|
| 1705 | 166x |
draw_donut_node_base( |
| 1706 | 166x |
x, y, node_size[i], |
| 1707 | 166x |
values = donut_vals, |
| 1708 | 166x |
colors = donut_cols, |
| 1709 | 166x |
default_color = node_fill[i], |
| 1710 | 166x |
inner_ratio = donut_inner_ratios[i], |
| 1711 | 166x |
bg_color = donut_bg_colors[i], |
| 1712 | 166x |
center_color = node_fill[i], |
| 1713 | 166x |
border.col = effective_donut_border_col, |
| 1714 | 166x |
border.width = node_border_width[i], |
| 1715 | 166x |
donut_border.width = donut_border_width, |
| 1716 | 166x |
outer_border.col = effective_outer_border_col, |
| 1717 | 166x |
border.lty = effective_border_lty, |
| 1718 | 166x |
show_value = donut_show_values[i], |
| 1719 | 166x |
value_cex = donut_value_sizes[i], |
| 1720 | 166x |
value_col = donut_value_colors[i], |
| 1721 | 166x |
value_fontface = donut_value_fontfaces[i], |
| 1722 | 166x |
value_fontfamily = donut_value_fontfamilies[i], |
| 1723 | 166x |
value_digits = donut_value_digits, |
| 1724 | 166x |
value_prefix = donut_value_prefix, |
| 1725 | 166x |
value_suffix = donut_value_suffix |
| 1726 |
) |
|
| 1727 |
} |
|
| 1728 | ||
| 1729 | 2438x |
} else if (has_pie) {
|
| 1730 |
# Pie only |
|
| 1731 | 48x |
pie_vals <- pie_values[[i]] |
| 1732 | 48x |
pie_cols <- if (!is.null(pie_colors) && length(pie_colors) >= i) pie_colors[[i]] else NULL |
| 1733 | ||
| 1734 | 48x |
draw_pie_node_base( |
| 1735 | 48x |
x, y, node_size[i], |
| 1736 | 48x |
values = pie_vals, |
| 1737 | 48x |
colors = pie_cols, |
| 1738 | 48x |
default_color = node_fill[i], |
| 1739 | 48x |
border.col = node_border_color[i], |
| 1740 | 48x |
border.width = node_border_width[i], |
| 1741 | 48x |
pie_border.width = pie_border_width |
| 1742 |
) |
|
| 1743 | ||
| 1744 |
} else {
|
|
| 1745 |
# Standard node |
|
| 1746 | 2390x |
if (use_pch && node_shape[i] == "circle") {
|
| 1747 |
# Fast point-based rendering |
|
| 1748 | 10x |
graphics::points(x, y, pch = 21, cex = node_size[i] * 20, |
| 1749 | 10x |
bg = node_fill[i], col = node_border_color[i], lwd = node_border_width[i]) |
| 1750 |
} else {
|
|
| 1751 | 2380x |
draw_node_base( |
| 1752 | 2380x |
x, y, node_size[i], node_size2[i], |
| 1753 | 2380x |
shape = node_shape[i], |
| 1754 | 2380x |
col = node_fill[i], |
| 1755 | 2380x |
border.col = node_border_color[i], |
| 1756 | 2380x |
border.width = node_border_width[i] |
| 1757 |
) |
|
| 1758 |
} |
|
| 1759 |
} |
|
| 1760 |
} |
|
| 1761 | ||
| 1762 |
# Render labels |
|
| 1763 | 663x |
if (!is.null(labels)) {
|
| 1764 |
# Vectorize label parameters (strict: length 1 or n) |
|
| 1765 | 661x |
label_angles <- expand_param(label_angle, n, "label_angle") |
| 1766 | 661x |
label_positions <- expand_param(label_position, n, "label_position") |
| 1767 | 661x |
label_fontfaces <- expand_param(label_fontface, n, "label_fontface") |
| 1768 | 661x |
label_fontfamilies <- expand_param(label_fontfamily, n, "label_fontfamily") |
| 1769 | 661x |
label_hjusts <- expand_param(label_hjust, n, "label_hjust") |
| 1770 | 661x |
label_vjusts <- expand_param(label_vjust, n, "label_vjust") |
| 1771 | ||
| 1772 | 661x |
for (i in seq_len(n)) {
|
| 1773 | 2656x |
if (!is.null(labels[i]) && !is.na(labels[i]) && labels[i] != "") {
|
| 1774 | 2654x |
lx <- layout[i, 1] |
| 1775 | 2654x |
ly <- layout[i, 2] |
| 1776 | ||
| 1777 |
# Adjust position based on per-node label_position |
|
| 1778 | 2654x |
offset <- node_size[i] * 1.2 |
| 1779 | ||
| 1780 | 2654x |
if (label_positions[i] == "above") {
|
| 1781 | 11x |
ly <- ly + offset |
| 1782 | 2643x |
} else if (label_positions[i] == "below") {
|
| 1783 | 7x |
ly <- ly - offset |
| 1784 | 2636x |
} else if (label_positions[i] == "left") {
|
| 1785 | 7x |
lx <- lx - offset |
| 1786 | 2629x |
} else if (label_positions[i] == "right") {
|
| 1787 | 7x |
lx <- lx + offset |
| 1788 |
} |
|
| 1789 |
# "center" - no offset |
|
| 1790 | ||
| 1791 |
# Convert fontface string to numeric (per-node) |
|
| 1792 | 2654x |
fontface_num <- switch(label_fontfaces[i], |
| 1793 | 2654x |
"plain" = 1, |
| 1794 | 2654x |
"bold" = 2, |
| 1795 | 2654x |
"italic" = 3, |
| 1796 | 2654x |
"bold.italic" = 4, |
| 1797 | 2654x |
1 |
| 1798 |
) |
|
| 1799 | ||
| 1800 | 2654x |
draw_node_label_base( |
| 1801 | 2654x |
lx, ly, |
| 1802 | 2654x |
label = labels[i], |
| 1803 | 2654x |
cex = label_size[i], |
| 1804 | 2654x |
col = label_color[i], |
| 1805 | 2654x |
font = fontface_num, |
| 1806 | 2654x |
family = label_fontfamilies[i], |
| 1807 | 2654x |
hjust = label_hjusts[i], |
| 1808 | 2654x |
vjust = label_vjusts[i], |
| 1809 | 2654x |
srt = label_angles[i] |
| 1810 |
) |
|
| 1811 |
} |
|
| 1812 |
} |
|
| 1813 |
} |
|
| 1814 |
} |
|
| 1815 | ||
| 1816 | ||
| 1817 |
#' Render Legend for splot |
|
| 1818 |
#' |
|
| 1819 |
#' Renders a comprehensive legend showing node groups, edge weight colors, |
|
| 1820 |
#' and optionally node sizes. |
|
| 1821 |
#' |
|
| 1822 |
#' @param groups Group assignments for nodes. |
|
| 1823 |
#' @param node_names Names for legend entries. |
|
| 1824 |
#' @param nodes Node data frame. |
|
| 1825 |
#' @param node_colors Vector of node colors. |
|
| 1826 |
#' @param position Legend position. |
|
| 1827 |
#' @param cex Text size. |
|
| 1828 |
#' @param show_edge_colors Logical: show positive/negative edge color legend? |
|
| 1829 |
#' @param positive_color Positive edge color. |
|
| 1830 |
#' @param negative_color Negative edge color. |
|
| 1831 |
#' @param has_pos_edges Logical: are there positive weighted edges? |
|
| 1832 |
#' @param has_neg_edges Logical: are there negative weighted edges? |
|
| 1833 |
#' @param show_node_sizes Logical: show node size legend? |
|
| 1834 |
#' @param node_size Vector of node sizes. |
|
| 1835 |
#' @keywords internal |
|
| 1836 |
render_legend_splot <- function(groups, node_names, nodes, node_colors, |
|
| 1837 |
position = "topright", cex = 0.8, |
|
| 1838 |
show_edge_colors = FALSE, |
|
| 1839 |
positive_color = "#2E7D32", negative_color = "#C62828", |
|
| 1840 |
has_pos_edges = FALSE, has_neg_edges = FALSE, |
|
| 1841 |
show_node_sizes = FALSE, node_size = NULL) {
|
|
| 1842 | ||
| 1843 | 22x |
n <- length(node_colors) |
| 1844 | ||
| 1845 |
# Collect all legend components |
|
| 1846 | 22x |
legend_labels <- character(0) |
| 1847 | 22x |
legend_colors <- character(0) |
| 1848 | 22x |
legend_pch <- integer(0) |
| 1849 | 22x |
legend_lty <- integer(0) |
| 1850 | 22x |
legend_lwd <- numeric(0) |
| 1851 | 22x |
legend_pt_cex <- numeric(0) |
| 1852 | ||
| 1853 |
# ========================================= |
|
| 1854 |
# 1. NODE GROUPS (filled squares) |
|
| 1855 |
# ========================================= |
|
| 1856 | 22x |
if (!is.null(groups)) {
|
| 1857 | 10x |
unique_groups <- unique(groups) |
| 1858 | ||
| 1859 |
# Get color for each group (first node of that group) |
|
| 1860 | 10x |
group_colors <- sapply(unique_groups, function(g) {
|
| 1861 | 25x |
idx <- which(groups == g)[1] |
| 1862 | 25x |
node_colors[idx] |
| 1863 |
}) |
|
| 1864 | ||
| 1865 | 10x |
group_labels <- if (!is.null(node_names)) {
|
| 1866 | 4x |
sapply(unique_groups, function(g) {
|
| 1867 | 11x |
idx <- which(groups == g)[1] |
| 1868 | 4x |
if (length(node_names) >= idx) node_names[idx] else as.character(g) |
| 1869 |
}) |
|
| 1870 |
} else {
|
|
| 1871 | 6x |
as.character(unique_groups) |
| 1872 |
} |
|
| 1873 | ||
| 1874 | 10x |
legend_labels <- c(legend_labels, group_labels) |
| 1875 | 10x |
legend_colors <- c(legend_colors, group_colors) |
| 1876 | 10x |
legend_pch <- c(legend_pch, rep(22, length(unique_groups))) # filled square |
| 1877 | 10x |
legend_lty <- c(legend_lty, rep(NA, length(unique_groups))) |
| 1878 | 10x |
legend_lwd <- c(legend_lwd, rep(NA, length(unique_groups))) |
| 1879 | 10x |
legend_pt_cex <- c(legend_pt_cex, rep(2, length(unique_groups))) |
| 1880 |
} |
|
| 1881 | ||
| 1882 |
# ========================================= |
|
| 1883 |
# 2. EDGE COLORS (lines) |
|
| 1884 |
# ========================================= |
|
| 1885 | 22x |
if (show_edge_colors && (has_pos_edges || has_neg_edges)) {
|
| 1886 |
# Add separator if we have groups |
|
| 1887 | 18x |
if (length(legend_labels) > 0) {
|
| 1888 | 9x |
legend_labels <- c(legend_labels, "") |
| 1889 | 9x |
legend_colors <- c(legend_colors, NA) |
| 1890 | 9x |
legend_pch <- c(legend_pch, NA) |
| 1891 | 9x |
legend_lty <- c(legend_lty, 0) |
| 1892 | 9x |
legend_lwd <- c(legend_lwd, NA) |
| 1893 | 9x |
legend_pt_cex <- c(legend_pt_cex, NA) |
| 1894 |
} |
|
| 1895 | ||
| 1896 | 18x |
if (has_pos_edges) {
|
| 1897 | 18x |
legend_labels <- c(legend_labels, "Positive") |
| 1898 | 18x |
legend_colors <- c(legend_colors, positive_color) |
| 1899 | 18x |
legend_pch <- c(legend_pch, NA) |
| 1900 | 18x |
legend_lty <- c(legend_lty, 1) |
| 1901 | 18x |
legend_lwd <- c(legend_lwd, 2) |
| 1902 | 18x |
legend_pt_cex <- c(legend_pt_cex, NA) |
| 1903 |
} |
|
| 1904 | ||
| 1905 | 18x |
if (has_neg_edges) {
|
| 1906 | 2x |
legend_labels <- c(legend_labels, "Negative") |
| 1907 | 2x |
legend_colors <- c(legend_colors, negative_color) |
| 1908 | 2x |
legend_pch <- c(legend_pch, NA) |
| 1909 | 2x |
legend_lty <- c(legend_lty, 1) |
| 1910 | 2x |
legend_lwd <- c(legend_lwd, 2) |
| 1911 | 2x |
legend_pt_cex <- c(legend_pt_cex, NA) |
| 1912 |
} |
|
| 1913 |
} |
|
| 1914 | ||
| 1915 |
# ========================================= |
|
| 1916 |
# 3. NODE SIZES (circles of different sizes) |
|
| 1917 |
# ========================================= |
|
| 1918 | 22x |
if (show_node_sizes && !is.null(node_size) && length(unique(node_size)) > 1) {
|
| 1919 |
# Add separator |
|
| 1920 | 5x |
if (length(legend_labels) > 0) {
|
| 1921 | 4x |
legend_labels <- c(legend_labels, "") |
| 1922 | 4x |
legend_colors <- c(legend_colors, NA) |
| 1923 | 4x |
legend_pch <- c(legend_pch, NA) |
| 1924 | 4x |
legend_lty <- c(legend_lty, 0) |
| 1925 | 4x |
legend_lwd <- c(legend_lwd, NA) |
| 1926 | 4x |
legend_pt_cex <- c(legend_pt_cex, NA) |
| 1927 |
} |
|
| 1928 | ||
| 1929 |
# Show min, median, max sizes |
|
| 1930 | 5x |
size_range <- range(node_size) |
| 1931 | 5x |
size_med <- median(node_size) |
| 1932 | 5x |
size_vals <- c(size_range[1], size_med, size_range[2]) |
| 1933 | 5x |
size_labels <- c( |
| 1934 | 5x |
paste0("Small (", round(size_range[1], 1), ")"),
|
| 1935 | 5x |
paste0("Medium (", round(size_med, 1), ")"),
|
| 1936 | 5x |
paste0("Large (", round(size_range[2], 1), ")")
|
| 1937 |
) |
|
| 1938 | ||
| 1939 |
# Scale for legend display |
|
| 1940 | 5x |
scale_factor <- 15 # Adjust for visual appearance |
| 1941 | 5x |
size_cex <- size_vals * scale_factor |
| 1942 | ||
| 1943 | 5x |
legend_labels <- c(legend_labels, size_labels) |
| 1944 | 5x |
legend_colors <- c(legend_colors, rep("gray50", 3))
|
| 1945 | 5x |
legend_pch <- c(legend_pch, rep(21, 3)) # filled circle |
| 1946 | 5x |
legend_lty <- c(legend_lty, rep(NA, 3)) |
| 1947 | 5x |
legend_lwd <- c(legend_lwd, rep(NA, 3)) |
| 1948 | 5x |
legend_pt_cex <- c(legend_pt_cex, size_cex) |
| 1949 |
} |
|
| 1950 | ||
| 1951 |
# ========================================= |
|
| 1952 |
# Draw legend if we have entries |
|
| 1953 |
# ========================================= |
|
| 1954 | 22x |
if (length(legend_labels) == 0) {
|
| 1955 | 2x |
return(invisible()) |
| 1956 |
} |
|
| 1957 | ||
| 1958 |
# Replace NA colors with transparent for proper rendering |
|
| 1959 | 20x |
legend_colors[is.na(legend_colors)] <- "transparent" |
| 1960 | ||
| 1961 |
# Determine which elements to show |
|
| 1962 | 20x |
has_points <- any(!is.na(legend_pch) & legend_pch > 0) |
| 1963 | 20x |
has_lines <- any(!is.na(legend_lty) & legend_lty > 0) |
| 1964 | ||
| 1965 |
# Build legend |
|
| 1966 | 20x |
graphics::legend( |
| 1967 | 20x |
position, |
| 1968 | 20x |
legend = legend_labels, |
| 1969 | 20x |
col = legend_colors, |
| 1970 | 20x |
pch = if (has_points) legend_pch else NULL, |
| 1971 | 20x |
lty = if (has_lines) legend_lty else NULL, |
| 1972 | 20x |
lwd = if (has_lines) legend_lwd else NULL, |
| 1973 | 20x |
pt.cex = if (has_points) legend_pt_cex else NULL, |
| 1974 | 20x |
pt.bg = if (has_points) legend_colors else NULL, |
| 1975 | 20x |
bty = "o", |
| 1976 | 20x |
bg = "white", |
| 1977 | 20x |
cex = cex, |
| 1978 | 20x |
seg.len = 1.5 |
| 1979 |
) |
|
| 1980 |
} |
| 1 |
#' @title Special Node Shapes |
|
| 2 |
#' @description Special node shape drawing functions (ellipse, heart, star, pie). |
|
| 3 |
#' @name shapes-special |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Draw Ellipse Node |
|
| 8 |
#' @keywords internal |
|
| 9 |
draw_ellipse <- function(x, y, size, fill, border_color, border_width, |
|
| 10 |
alpha = 1, aspect = 0.6, ...) {
|
|
| 11 | 14x |
fill_col <- adjust_alpha(fill, alpha) |
| 12 | 14x |
border_col <- adjust_alpha(border_color, alpha) |
| 13 | ||
| 14 |
# Ellipse as polygon approximation |
|
| 15 | 14x |
n_points <- 50 |
| 16 | 14x |
angles <- seq(0, 2*pi, length.out = n_points + 1)[-1] |
| 17 | 14x |
xs <- x + size * cos(angles) |
| 18 | 14x |
ys <- y + size * aspect * sin(angles) |
| 19 | ||
| 20 | 14x |
grid::polygonGrob( |
| 21 | 14x |
x = grid::unit(xs, "npc"), |
| 22 | 14x |
y = grid::unit(ys, "npc"), |
| 23 | 14x |
gp = grid::gpar( |
| 24 | 14x |
fill = fill_col, |
| 25 | 14x |
col = border_col, |
| 26 | 14x |
lwd = border_width |
| 27 |
) |
|
| 28 |
) |
|
| 29 |
} |
|
| 30 | ||
| 31 |
#' Draw Heart Node |
|
| 32 |
#' @keywords internal |
|
| 33 |
draw_heart <- function(x, y, size, fill, border_color, border_width, |
|
| 34 |
alpha = 1, ...) {
|
|
| 35 | 17x |
fill_col <- adjust_alpha(fill, alpha) |
| 36 | 17x |
border_col <- adjust_alpha(border_color, alpha) |
| 37 | ||
| 38 |
# Heart shape using parametric equations |
|
| 39 | 17x |
n_points <- 100 |
| 40 | 17x |
t <- seq(0, 2*pi, length.out = n_points) |
| 41 | ||
| 42 |
# Heart parametric equations |
|
| 43 | 17x |
hx <- 16 * sin(t)^3 |
| 44 | 17x |
hy <- 13 * cos(t) - 5 * cos(2*t) - 2 * cos(3*t) - cos(4*t) |
| 45 | ||
| 46 |
# Normalize and scale |
|
| 47 | 17x |
hx <- hx / max(abs(hx)) |
| 48 | 17x |
hy <- hy / max(abs(hy)) |
| 49 | ||
| 50 | 17x |
xs <- x + size * 0.8 * hx |
| 51 | 17x |
ys <- y + size * 0.8 * hy |
| 52 | ||
| 53 | 17x |
grid::polygonGrob( |
| 54 | 17x |
x = grid::unit(xs, "npc"), |
| 55 | 17x |
y = grid::unit(ys, "npc"), |
| 56 | 17x |
gp = grid::gpar( |
| 57 | 17x |
fill = fill_col, |
| 58 | 17x |
col = border_col, |
| 59 | 17x |
lwd = border_width |
| 60 |
) |
|
| 61 |
) |
|
| 62 |
} |
|
| 63 | ||
| 64 |
#' Draw Star Node |
|
| 65 |
#' @keywords internal |
|
| 66 |
draw_star <- function(x, y, size, fill, border_color, border_width, |
|
| 67 |
alpha = 1, n_points = 5, inner_ratio = 0.4, ...) {
|
|
| 68 | 21x |
fill_col <- adjust_alpha(fill, alpha) |
| 69 | 21x |
border_col <- adjust_alpha(border_color, alpha) |
| 70 | ||
| 71 |
# Alternating outer and inner points |
|
| 72 | 21x |
n_vertices <- n_points * 2 |
| 73 | 21x |
angles <- seq(pi/2, pi/2 + 2*pi * (1 - 1/n_vertices), length.out = n_vertices) |
| 74 | 21x |
radii <- rep(c(size, size * inner_ratio), n_points) |
| 75 | ||
| 76 | 21x |
xs <- x + radii * cos(angles) |
| 77 | 21x |
ys <- y + radii * sin(angles) |
| 78 | ||
| 79 | 21x |
grid::polygonGrob( |
| 80 | 21x |
x = grid::unit(xs, "npc"), |
| 81 | 21x |
y = grid::unit(ys, "npc"), |
| 82 | 21x |
gp = grid::gpar( |
| 83 | 21x |
fill = fill_col, |
| 84 | 21x |
col = border_col, |
| 85 | 21x |
lwd = border_width |
| 86 |
) |
|
| 87 |
) |
|
| 88 |
} |
|
| 89 | ||
| 90 |
#' Draw Pie Node |
|
| 91 |
#' |
|
| 92 |
#' Draw a pie chart node with multiple segments. |
|
| 93 |
#' |
|
| 94 |
#' @param pie_border_width Border width for pie segments (optional, defaults to border_width * 0.5). |
|
| 95 |
#' @param default_color Fallback color when colors is NULL and there's a single segment. |
|
| 96 |
#' @keywords internal |
|
| 97 |
draw_pie <- function(x, y, size, fill, border_color, border_width, |
|
| 98 |
alpha = 1, values = NULL, colors = NULL, |
|
| 99 |
pie_border_width = NULL, default_color = NULL, ...) {
|
|
| 100 | 24x |
fill_col <- adjust_alpha(fill, alpha) |
| 101 | 24x |
border_col <- adjust_alpha(border_color, alpha) |
| 102 | ||
| 103 |
# Use specific pie_border_width if provided, else default |
|
| 104 | 24x |
segment_border <- if (!is.null(pie_border_width)) pie_border_width else border_width * 0.5 |
| 105 | ||
| 106 |
# If no values, draw a simple circle |
|
| 107 | 24x |
if (is.null(values) || length(values) <= 1) {
|
| 108 |
# Use default_color if provided |
|
| 109 | 10x |
actual_fill <- if (!is.null(default_color)) default_color else fill |
| 110 | 10x |
return(draw_circle(x, y, size, actual_fill, border_color, border_width, alpha, ...)) |
| 111 |
} |
|
| 112 | ||
| 113 |
# Normalize values to proportions |
|
| 114 | 14x |
props <- values / sum(values) |
| 115 | ||
| 116 |
# Default colors if not provided |
|
| 117 | 14x |
if (is.null(colors)) {
|
| 118 | 6x |
colors <- grDevices::rainbow(length(values), alpha = alpha) |
| 119 |
} else {
|
|
| 120 | 8x |
colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 121 |
} |
|
| 122 | ||
| 123 |
# Create pie slices |
|
| 124 | 14x |
grobs <- list() |
| 125 | 14x |
start_angle <- pi/2 |
| 126 | ||
| 127 | 14x |
for (i in seq_along(props)) {
|
| 128 | 38x |
end_angle <- start_angle - 2 * pi * props[i] |
| 129 | ||
| 130 |
# Create arc |
|
| 131 | 38x |
n_points <- max(20, ceiling(50 * props[i])) |
| 132 | 38x |
angles <- seq(start_angle, end_angle, length.out = n_points) |
| 133 | ||
| 134 | 38x |
xs <- c(x, x + size * cos(angles), x) |
| 135 | 38x |
ys <- c(y, y + size * sin(angles), y) |
| 136 | ||
| 137 |
# Use NA for border if segment_border is 0 or very small |
|
| 138 | 38x |
seg_col <- if (!is.null(segment_border) && segment_border > 0.1) border_col else NA |
| 139 | ||
| 140 | 38x |
grobs[[i]] <- grid::polygonGrob( |
| 141 | 38x |
x = grid::unit(xs, "npc"), |
| 142 | 38x |
y = grid::unit(ys, "npc"), |
| 143 | 38x |
gp = grid::gpar( |
| 144 | 38x |
fill = colors[i], |
| 145 | 38x |
col = seg_col, |
| 146 | 38x |
lwd = segment_border |
| 147 |
) |
|
| 148 |
) |
|
| 149 | ||
| 150 | 38x |
start_angle <- end_angle |
| 151 |
} |
|
| 152 | ||
| 153 |
# Add outer border |
|
| 154 | 14x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 155 | 14x |
x = grid::unit(x, "npc"), |
| 156 | 14x |
y = grid::unit(y, "npc"), |
| 157 | 14x |
r = grid::unit(size, "npc"), |
| 158 | 14x |
gp = grid::gpar( |
| 159 | 14x |
fill = NA, |
| 160 | 14x |
col = border_col, |
| 161 | 14x |
lwd = border_width |
| 162 |
) |
|
| 163 |
) |
|
| 164 | ||
| 165 | 14x |
do.call(grid::gList, grobs) |
| 166 |
} |
|
| 167 | ||
| 168 |
#' Draw Polygon Donut Node |
|
| 169 |
#' |
|
| 170 |
#' Draws a donut ring on a polygon shape where segments follow polygon edges. |
|
| 171 |
#' The fill shows a proportion (0-1) as filled segments starting from the top vertex. |
|
| 172 |
#' |
|
| 173 |
#' @param x,y Node center coordinates (NPC units). |
|
| 174 |
#' @param size Node radius (NPC units). |
|
| 175 |
#' @param fill Fill color for the donut ring. |
|
| 176 |
#' @param border_color Border color. |
|
| 177 |
#' @param border_width Border line width. |
|
| 178 |
#' @param alpha Transparency (0-1). |
|
| 179 |
#' @param values Single numeric value (0-1) specifying fill proportion. |
|
| 180 |
#' 0.1 = 10% filled, 0.5 = 50% filled, 1.0 = full ring. |
|
| 181 |
#' @param colors Override fill color (optional). |
|
| 182 |
#' @param inner_ratio Ratio of inner to outer radius (0-1). Default 0.5. |
|
| 183 |
#' @param bg_color Background color for unfilled portion. Default "gray90". |
|
| 184 |
#' @param donut_shape Base polygon shape: "circle", "square", "hexagon", "triangle", "diamond", "pentagon". |
|
| 185 |
#' @param show_value Logical: show value in center? Default FALSE. |
|
| 186 |
#' @param value_size Font size for center value. |
|
| 187 |
#' @param value_color Color for center value text. |
|
| 188 |
#' @param value_fontface Font face for center value. |
|
| 189 |
#' @param value_fontfamily Font family for center value. |
|
| 190 |
#' @param value_digits Decimal places for value display. |
|
| 191 |
#' @param value_prefix Text before value. |
|
| 192 |
#' @param value_suffix Text after value. |
|
| 193 |
#' @param value_format Custom format function. |
|
| 194 |
#' @param donut_border_width Border width for donut ring (NULL = use border_width). |
|
| 195 |
#' @keywords internal |
|
| 196 |
draw_polygon_donut <- function(x, y, size, fill, border_color, border_width, |
|
| 197 |
alpha = 1, values = NULL, colors = NULL, |
|
| 198 |
inner_ratio = 0.5, bg_color = "gray90", |
|
| 199 |
donut_shape = "square", |
|
| 200 |
show_value = TRUE, value_size = 8, value_color = "black", |
|
| 201 |
value_fontface = "bold", value_fontfamily = "sans", |
|
| 202 |
value_digits = 2, value_prefix = "", value_suffix = "", |
|
| 203 |
value_format = NULL, donut_border_width = NULL, ...) {
|
|
| 204 | 50x |
fill_col <- adjust_alpha(fill, alpha) |
| 205 | 50x |
border_col <- adjust_alpha(border_color, alpha) |
| 206 | 50x |
bg_col <- adjust_alpha(bg_color, alpha) |
| 207 | ||
| 208 | 50x |
ring_border <- if (!is.null(donut_border_width)) donut_border_width else border_width |
| 209 | ||
| 210 |
# Get outer polygon vertices |
|
| 211 | 50x |
outer <- get_donut_base_vertices(donut_shape, x, y, size) |
| 212 | ||
| 213 |
# Get inner polygon vertices |
|
| 214 | 50x |
inner <- inset_polygon_vertices(outer, inner_ratio) |
| 215 | ||
| 216 | 50x |
n_verts <- length(outer$x) |
| 217 | 50x |
grobs <- list() |
| 218 | 50x |
center_value <- NULL |
| 219 | ||
| 220 |
# Helper to draw a ring segment between two vertex pairs |
|
| 221 | 50x |
draw_ring_segment <- function(idx_start, idx_end, segment_col) {
|
| 222 | 488x |
seg_x <- c(outer$x[idx_start], outer$x[idx_end], inner$x[idx_end], inner$x[idx_start]) |
| 223 | 488x |
seg_y <- c(outer$y[idx_start], outer$y[idx_end], inner$y[idx_end], inner$y[idx_start]) |
| 224 | ||
| 225 | 488x |
grid::polygonGrob( |
| 226 | 488x |
x = grid::unit(seg_x, "npc"), |
| 227 | 488x |
y = grid::unit(seg_y, "npc"), |
| 228 | 488x |
gp = grid::gpar(fill = segment_col, col = NA) |
| 229 |
) |
|
| 230 |
} |
|
| 231 | ||
| 232 | 50x |
if (is.null(values) || length(values) == 0) {
|
| 233 | 3x |
values <- 1 |
| 234 | 3x |
if (is.null(colors)) colors <- fill_col |
| 235 |
} |
|
| 236 | ||
| 237 | 50x |
if (length(values) == 1) {
|
| 238 |
# Progress donut |
|
| 239 | 46x |
prop <- max(0, min(1, values)) |
| 240 | 46x |
center_value <- prop |
| 241 | ||
| 242 |
# Draw background ring |
|
| 243 | 46x |
for (i in seq_len(n_verts)) {
|
| 244 | 304x |
i_next <- if (i == n_verts) 1 else i + 1 |
| 245 | 304x |
grobs[[length(grobs) + 1]] <- draw_ring_segment(i, i_next, bg_col) |
| 246 |
} |
|
| 247 | ||
| 248 |
# Draw filled portion |
|
| 249 | 46x |
if (prop > 0) {
|
| 250 | 46x |
segment_col <- if (!is.null(colors)) colors[1] else fill_col |
| 251 | 46x |
filled_verts <- max(1, round(prop * n_verts)) |
| 252 | ||
| 253 | 46x |
for (i in seq_len(filled_verts)) {
|
| 254 | 167x |
i_next <- if (i == n_verts) 1 else i + 1 |
| 255 | 167x |
grobs[[length(grobs) + 1]] <- draw_ring_segment(i, i_next, segment_col) |
| 256 |
} |
|
| 257 |
} |
|
| 258 |
} else {
|
|
| 259 |
# Multi-segment donut |
|
| 260 | 4x |
props <- values / sum(values) |
| 261 | 4x |
n_seg <- length(props) |
| 262 | ||
| 263 | 4x |
if (is.null(colors)) {
|
| 264 | 2x |
colors <- grDevices::rainbow(n_seg, s = 0.7, v = 0.9) |
| 265 |
} |
|
| 266 | 4x |
colors <- recycle_to_length(colors, n_seg) |
| 267 | ||
| 268 | 4x |
vert_idx <- 1 |
| 269 | 4x |
for (seg in seq_len(n_seg)) {
|
| 270 | 29x |
seg_verts <- max(1, round(props[seg] * n_verts)) |
| 271 | 29x |
seg_col <- adjust_alpha(colors[seg], alpha) |
| 272 | ||
| 273 | 29x |
for (j in seq_len(seg_verts)) {
|
| 274 | 17x |
if (vert_idx > n_verts) break |
| 275 | 17x |
i_next <- if (vert_idx == n_verts) 1 else vert_idx + 1 |
| 276 | 17x |
grobs[[length(grobs) + 1]] <- draw_ring_segment(vert_idx, i_next, seg_col) |
| 277 | 17x |
vert_idx <- vert_idx + 1 |
| 278 |
} |
|
| 279 |
} |
|
| 280 |
} |
|
| 281 | ||
| 282 |
# Outer border |
|
| 283 | 50x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 284 | 50x |
x = grid::unit(outer$x, "npc"), |
| 285 | 50x |
y = grid::unit(outer$y, "npc"), |
| 286 | 50x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 287 |
) |
|
| 288 | ||
| 289 |
# Inner border and fill (center uses node fill color) |
|
| 290 | 50x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 291 | 50x |
x = grid::unit(inner$x, "npc"), |
| 292 | 50x |
y = grid::unit(inner$y, "npc"), |
| 293 | 50x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = ring_border) |
| 294 |
) |
|
| 295 | ||
| 296 |
# Value text in center |
|
| 297 | 50x |
if (show_value && !is.null(center_value)) {
|
| 298 | 14x |
if (!is.null(value_format) && is.function(value_format)) {
|
| 299 | 2x |
formatted_value <- value_format(center_value) |
| 300 |
} else {
|
|
| 301 | 12x |
formatted_value <- round(center_value, value_digits) |
| 302 |
} |
|
| 303 | 14x |
label_text <- paste0(value_prefix, formatted_value, value_suffix) |
| 304 | ||
| 305 | 14x |
fontface_num <- switch(value_fontface, |
| 306 | 14x |
"plain" = 1, "bold" = 2, "italic" = 3, "bold.italic" = 4, 2 |
| 307 |
) |
|
| 308 | ||
| 309 | 14x |
grobs[[length(grobs) + 1]] <- grid::textGrob( |
| 310 | 14x |
label = label_text, |
| 311 | 14x |
x = grid::unit(x, "npc"), |
| 312 | 14x |
y = grid::unit(y, "npc"), |
| 313 | 14x |
gp = grid::gpar( |
| 314 | 14x |
fontsize = value_size, col = value_color, |
| 315 | 14x |
fontface = fontface_num, fontfamily = value_fontfamily |
| 316 |
) |
|
| 317 |
) |
|
| 318 |
} |
|
| 319 | ||
| 320 | 50x |
do.call(grid::gList, grobs) |
| 321 |
} |
|
| 322 | ||
| 323 |
#' Draw Donut Node |
|
| 324 |
#' |
|
| 325 |
#' Draw a donut chart node showing a fill proportion (0-1) as an arc. |
|
| 326 |
#' The fill starts from 12 o'clock (top) and fills clockwise. |
|
| 327 |
#' |
|
| 328 |
#' @param x,y Node center coordinates (NPC units). |
|
| 329 |
#' @param size Node radius (NPC units). |
|
| 330 |
#' @param fill Fill color for the donut ring. |
|
| 331 |
#' @param border_color Border color. |
|
| 332 |
#' @param border_width Border line width. |
|
| 333 |
#' @param alpha Transparency (0-1). |
|
| 334 |
#' @param values Single numeric value (0-1) specifying fill proportion. |
|
| 335 |
#' 0.1 = 10% filled arc, 0.5 = 50% filled, 1.0 = full ring. |
|
| 336 |
#' @param colors Override fill color (optional). |
|
| 337 |
#' @param inner_ratio Ratio of inner to outer radius (0-1). Default 0.5. |
|
| 338 |
#' @param bg_color Background color for unfilled portion. Default "gray90". |
|
| 339 |
#' @param show_value Logical: show value in center? Default FALSE. |
|
| 340 |
#' @param value_size Font size for center value. |
|
| 341 |
#' @param value_color Color for center value text. |
|
| 342 |
#' @param value_fontface Font face for center value. |
|
| 343 |
#' @param value_fontfamily Font family for center value. |
|
| 344 |
#' @param value_digits Decimal places for value display. |
|
| 345 |
#' @param value_prefix Text before value (e.g., "$"). |
|
| 346 |
#' @param value_suffix Text after value (e.g., "%"). |
|
| 347 |
#' @param value_format Custom format function (overrides digits). |
|
| 348 |
#' @param donut_border_width Border width for donut ring (NULL = use border_width). |
|
| 349 |
#' @keywords internal |
|
| 350 |
draw_donut <- function(x, y, size, fill, border_color, border_width, |
|
| 351 |
alpha = 1, values = NULL, colors = NULL, |
|
| 352 |
inner_ratio = 0.5, bg_color = "gray90", |
|
| 353 |
show_value = TRUE, value_size = 8, value_color = "black", |
|
| 354 |
value_fontface = "bold", value_fontfamily = "sans", |
|
| 355 |
value_digits = 2, value_prefix = "", value_suffix = "", |
|
| 356 |
value_format = NULL, donut_border_width = NULL, ...) {
|
|
| 357 | 124x |
fill_col <- adjust_alpha(fill, alpha) |
| 358 | 124x |
border_col <- adjust_alpha(border_color, alpha) |
| 359 | 124x |
bg_col <- adjust_alpha(bg_color, alpha) |
| 360 | ||
| 361 |
# Use specific donut_border_width if provided, else default to border_width |
|
| 362 | 124x |
ring_border <- if (!is.null(donut_border_width)) donut_border_width else border_width |
| 363 | ||
| 364 | 124x |
outer_r <- size |
| 365 | 124x |
inner_r <- size * inner_ratio |
| 366 | ||
| 367 | 124x |
grobs <- list() |
| 368 | 124x |
center_value <- NULL |
| 369 | ||
| 370 |
# Use symbols() approach - convert to grob after drawing |
|
| 371 |
# This ensures proper aspect ratio handling |
|
| 372 | ||
| 373 |
# Get viewport dimensions to match circleGrob's radius calculation |
|
| 374 |
# circleGrob with NPC units uses min(width, height) as reference |
|
| 375 | 124x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 376 | 124x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 377 | ||
| 378 |
# Calculate scaling factors to match circleGrob behavior |
|
| 379 | 124x |
min_dim <- min(vp_width, vp_height) |
| 380 | 124x |
x_scale <- min_dim / vp_width |
| 381 | 124x |
y_scale <- min_dim / vp_height |
| 382 | ||
| 383 |
# Helper function to create pie wedge coordinates for a ring segment |
|
| 384 |
# Uses same scaling as circleGrob for perfect alignment |
|
| 385 | 124x |
make_ring_coords <- function(start_ang, end_ang, outer_radius, inner_radius, cx, cy, n_pts = 100) {
|
| 386 | 249x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 387 | ||
| 388 |
# Apply same scaling as circleGrob |
|
| 389 | 249x |
outer_x <- cx + (outer_radius * x_scale) * cos(angles) |
| 390 | 249x |
outer_y <- cy + (outer_radius * y_scale) * sin(angles) |
| 391 | ||
| 392 | 249x |
inner_x <- cx + (inner_radius * x_scale) * cos(rev(angles)) |
| 393 | 249x |
inner_y <- cy + (inner_radius * y_scale) * sin(rev(angles)) |
| 394 | ||
| 395 | 249x |
list(x = c(outer_x, inner_x), y = c(outer_y, inner_y)) |
| 396 |
} |
|
| 397 | ||
| 398 |
# Handle single value case |
|
| 399 | 124x |
if (is.null(values) || length(values) == 1) {
|
| 400 | 121x |
prop <- if (is.null(values)) 1 else values[1] |
| 401 | 121x |
prop <- max(0, min(1, prop)) |
| 402 | 121x |
center_value <- prop |
| 403 | ||
| 404 |
# Inset factor to keep fill inside border |
|
| 405 | 121x |
inset <- 0.97 |
| 406 | ||
| 407 |
# 1. Draw background ring (full circle) - slightly inside the border |
|
| 408 | 121x |
bg_coords <- make_ring_coords(0, 2 * pi, outer_r * inset, inner_r / inset, x, y, 200) |
| 409 | 121x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 410 | 121x |
x = grid::unit(bg_coords$x, "npc"), |
| 411 | 121x |
y = grid::unit(bg_coords$y, "npc"), |
| 412 | 121x |
gp = grid::gpar(fill = bg_col, col = NA) |
| 413 |
) |
|
| 414 | ||
| 415 |
# 2. Draw filled portion (from 12 o'clock clockwise) |
|
| 416 | 121x |
if (prop > 0) {
|
| 417 | 120x |
start_ang <- pi / 2 |
| 418 | 120x |
end_ang <- pi / 2 - 2 * pi * prop |
| 419 | 120x |
n_pts <- max(100, ceiling(300 * prop)) |
| 420 | 120x |
fill_coords <- make_ring_coords(start_ang, end_ang, outer_r * inset, inner_r / inset, x, y, n_pts) |
| 421 | 120x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 422 | 120x |
x = grid::unit(fill_coords$x, "npc"), |
| 423 | 120x |
y = grid::unit(fill_coords$y, "npc"), |
| 424 | 120x |
gp = grid::gpar(fill = fill_col, col = NA) |
| 425 |
) |
|
| 426 |
} |
|
| 427 | ||
| 428 |
# 3. Fill inner hole (center uses node fill color) |
|
| 429 | 121x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 430 | 121x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 431 | 121x |
r = grid::unit(inner_r, "npc"), |
| 432 | 121x |
gp = grid::gpar(fill = fill_col, col = NA) |
| 433 |
) |
|
| 434 | ||
| 435 |
# 4. Redraw borders for clean edges |
|
| 436 | 121x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 437 | 121x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 438 | 121x |
r = grid::unit(outer_r, "npc"), |
| 439 | 121x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 440 |
) |
|
| 441 | 121x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 442 | 121x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 443 | 121x |
r = grid::unit(inner_r, "npc"), |
| 444 | 121x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 445 |
) |
|
| 446 | ||
| 447 |
} else {
|
|
| 448 |
# Multiple values: donut with segments |
|
| 449 | 3x |
props <- values / sum(values) |
| 450 | ||
| 451 | 3x |
if (is.null(colors)) {
|
| 452 | 1x |
colors <- grDevices::rainbow(length(values), alpha = alpha) |
| 453 |
} else {
|
|
| 454 | 2x |
colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 455 |
} |
|
| 456 | ||
| 457 |
# Inset factor to keep fill inside border |
|
| 458 | 3x |
inset <- 0.97 |
| 459 | ||
| 460 |
# Draw arc segments |
|
| 461 | 3x |
start_ang <- pi / 2 |
| 462 | 3x |
for (i in seq_along(props)) {
|
| 463 | 8x |
end_ang <- start_ang - 2 * pi * props[i] |
| 464 | 8x |
n_pts <- max(50, ceiling(150 * props[i])) |
| 465 | 8x |
seg_coords <- make_ring_coords(start_ang, end_ang, outer_r * inset, inner_r / inset, x, y, n_pts) |
| 466 | 8x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 467 | 8x |
x = grid::unit(seg_coords$x, "npc"), |
| 468 | 8x |
y = grid::unit(seg_coords$y, "npc"), |
| 469 | 8x |
gp = grid::gpar(fill = colors[i], col = NA) |
| 470 |
) |
|
| 471 | 8x |
start_ang <- end_ang |
| 472 |
} |
|
| 473 | ||
| 474 |
# Fill inner hole (center uses node fill color) |
|
| 475 | 3x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 476 | 3x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 477 | 3x |
r = grid::unit(inner_r, "npc"), |
| 478 | 3x |
gp = grid::gpar(fill = fill_col, col = NA) |
| 479 |
) |
|
| 480 | ||
| 481 |
# Draw borders |
|
| 482 | 3x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 483 | 3x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 484 | 3x |
r = grid::unit(outer_r, "npc"), |
| 485 | 3x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 486 |
) |
|
| 487 | 3x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 488 | 3x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 489 | 3x |
r = grid::unit(inner_r, "npc"), |
| 490 | 3x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 491 |
) |
|
| 492 |
} |
|
| 493 | ||
| 494 |
# Add outer border |
|
| 495 | 124x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 496 | 124x |
x = grid::unit(x, "npc"), |
| 497 | 124x |
y = grid::unit(y, "npc"), |
| 498 | 124x |
r = grid::unit(outer_r, "npc"), |
| 499 | 124x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 500 |
) |
|
| 501 | ||
| 502 |
# Add inner border |
|
| 503 | 124x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 504 | 124x |
x = grid::unit(x, "npc"), |
| 505 | 124x |
y = grid::unit(y, "npc"), |
| 506 | 124x |
r = grid::unit(inner_r, "npc"), |
| 507 | 124x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 508 |
) |
|
| 509 | ||
| 510 |
# Add value text in center (for single value donut) |
|
| 511 | 124x |
if (show_value && !is.null(center_value)) {
|
| 512 |
# Format the value |
|
| 513 | 25x |
if (!is.null(value_format) && is.function(value_format)) {
|
| 514 | 4x |
formatted_value <- value_format(center_value) |
| 515 |
} else {
|
|
| 516 | 21x |
formatted_value <- round(center_value, value_digits) |
| 517 |
} |
|
| 518 | 25x |
label_text <- paste0(value_prefix, formatted_value, value_suffix) |
| 519 | ||
| 520 |
# Convert fontface string to numeric |
|
| 521 | 25x |
fontface_num <- switch(value_fontface, |
| 522 | 25x |
"plain" = 1, |
| 523 | 25x |
"bold" = 2, |
| 524 | 25x |
"italic" = 3, |
| 525 | 25x |
"bold.italic" = 4, |
| 526 | 25x |
2 # default to bold |
| 527 |
) |
|
| 528 | ||
| 529 | 25x |
grobs[[length(grobs) + 1]] <- grid::textGrob( |
| 530 | 25x |
label = label_text, |
| 531 | 25x |
x = grid::unit(x, "npc"), |
| 532 | 25x |
y = grid::unit(y, "npc"), |
| 533 | 25x |
gp = grid::gpar( |
| 534 | 25x |
fontsize = value_size, |
| 535 | 25x |
col = value_color, |
| 536 | 25x |
fontface = fontface_num, |
| 537 | 25x |
fontfamily = value_fontfamily |
| 538 |
) |
|
| 539 |
) |
|
| 540 |
} |
|
| 541 | ||
| 542 | 124x |
do.call(grid::gList, grobs) |
| 543 |
} |
|
| 544 | ||
| 545 |
#' Draw Donut with Inner Pie Node |
|
| 546 |
#' |
|
| 547 |
#' Draw a node with an outer donut ring showing a proportion and an inner |
|
| 548 |
#' pie chart with multiple segments. |
|
| 549 |
#' |
|
| 550 |
#' @param pie_border_width Border width for pie segments (optional). |
|
| 551 |
#' @param donut_border_width Border width for donut ring (optional). |
|
| 552 |
#' @keywords internal |
|
| 553 |
draw_donut_pie <- function(x, y, size, fill, border_color, border_width, |
|
| 554 |
alpha = 1, donut_value = NULL, pie_values = NULL, |
|
| 555 |
pie_colors = NULL, inner_ratio = 0.5, |
|
| 556 |
bg_color = "gray90", pie_border_width = NULL, |
|
| 557 |
donut_border_width = NULL, ...) {
|
|
| 558 | 11x |
fill_col <- adjust_alpha(fill, alpha) |
| 559 | 11x |
border_col <- adjust_alpha(border_color, alpha) |
| 560 | 11x |
bg_col <- adjust_alpha(bg_color, alpha) |
| 561 | ||
| 562 |
# Use specific border widths if provided |
|
| 563 | 11x |
ring_border <- if (!is.null(donut_border_width)) donut_border_width else border_width |
| 564 | 11x |
pie_segment_border <- if (!is.null(pie_border_width)) pie_border_width else border_width * 0.5 |
| 565 | ||
| 566 | 11x |
outer_r <- size |
| 567 | 11x |
inner_r <- size * inner_ratio |
| 568 | ||
| 569 | 11x |
grobs <- list() |
| 570 | ||
| 571 |
# Get viewport dimensions for aspect ratio correction |
|
| 572 | 11x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 573 | 11x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 574 | 11x |
min_dim <- min(vp_width, vp_height) |
| 575 | 11x |
x_scale <- min_dim / vp_width |
| 576 | 11x |
y_scale <- min_dim / vp_height |
| 577 | ||
| 578 |
# Helper function for ring coordinates |
|
| 579 | 11x |
make_ring_coords <- function(start_ang, end_ang, outer_radius, inner_radius, cx, cy, n_pts = 100) {
|
| 580 | 22x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 581 | 22x |
outer_x <- cx + (outer_radius * x_scale) * cos(angles) |
| 582 | 22x |
outer_y <- cy + (outer_radius * y_scale) * sin(angles) |
| 583 | 22x |
inner_x <- cx + (inner_radius * x_scale) * cos(rev(angles)) |
| 584 | 22x |
inner_y <- cy + (inner_radius * y_scale) * sin(rev(angles)) |
| 585 | 22x |
list(x = c(outer_x, inner_x), y = c(outer_y, inner_y)) |
| 586 |
} |
|
| 587 | ||
| 588 |
# Helper function for pie slice coordinates |
|
| 589 | 11x |
make_pie_coords <- function(start_ang, end_ang, radius, cx, cy, n_pts = 50) {
|
| 590 | 24x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 591 | 24x |
xs <- c(cx, cx + (radius * x_scale) * cos(angles), cx) |
| 592 | 24x |
ys <- c(cy, cy + (radius * y_scale) * sin(angles), cy) |
| 593 | 24x |
list(x = xs, y = ys) |
| 594 |
} |
|
| 595 | ||
| 596 | 11x |
inset <- 0.97 |
| 597 | ||
| 598 |
# 1. Draw outer donut ring (background) |
|
| 599 | 11x |
bg_coords <- make_ring_coords(0, 2 * pi, outer_r * inset, inner_r / inset, x, y, 200) |
| 600 | 11x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 601 | 11x |
x = grid::unit(bg_coords$x, "npc"), |
| 602 | 11x |
y = grid::unit(bg_coords$y, "npc"), |
| 603 | 11x |
gp = grid::gpar(fill = bg_col, col = NA) |
| 604 |
) |
|
| 605 | ||
| 606 |
# 2. Draw donut filled portion (if donut_value provided) |
|
| 607 | 11x |
donut_prop <- if (is.null(donut_value)) 1 else max(0, min(1, donut_value)) |
| 608 | 11x |
if (donut_prop > 0) {
|
| 609 | 11x |
start_ang <- pi / 2 |
| 610 | 11x |
end_ang <- pi / 2 - 2 * pi * donut_prop |
| 611 | 11x |
n_pts <- max(100, ceiling(300 * donut_prop)) |
| 612 | 11x |
fill_coords <- make_ring_coords(start_ang, end_ang, outer_r * inset, inner_r / inset, x, y, n_pts) |
| 613 | 11x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 614 | 11x |
x = grid::unit(fill_coords$x, "npc"), |
| 615 | 11x |
y = grid::unit(fill_coords$y, "npc"), |
| 616 | 11x |
gp = grid::gpar(fill = fill_col, col = NA) |
| 617 |
) |
|
| 618 |
} |
|
| 619 | ||
| 620 |
# 3. Draw inner pie chart |
|
| 621 | 11x |
pie_radius <- inner_r * 0.95 |
| 622 | 11x |
if (!is.null(pie_values) && length(pie_values) > 0) {
|
| 623 | 10x |
props <- pie_values / sum(pie_values) |
| 624 | ||
| 625 | 10x |
if (is.null(pie_colors)) {
|
| 626 | 2x |
pie_colors <- grDevices::rainbow(length(pie_values), alpha = alpha) |
| 627 |
} else {
|
|
| 628 | 8x |
pie_colors <- sapply(pie_colors, adjust_alpha, alpha = alpha) |
| 629 | 8x |
pie_colors <- rep(pie_colors, length.out = length(pie_values)) |
| 630 |
} |
|
| 631 | ||
| 632 | 10x |
start_ang <- pi / 2 |
| 633 | 10x |
for (i in seq_along(props)) {
|
| 634 | 24x |
end_ang <- start_ang - 2 * pi * props[i] |
| 635 | 24x |
n_pts <- max(30, ceiling(100 * props[i])) |
| 636 | 24x |
pie_coords <- make_pie_coords(start_ang, end_ang, pie_radius, x, y, n_pts) |
| 637 | 24x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 638 | 24x |
x = grid::unit(pie_coords$x, "npc"), |
| 639 | 24x |
y = grid::unit(pie_coords$y, "npc"), |
| 640 | 24x |
gp = grid::gpar(fill = pie_colors[i], col = NA) |
| 641 |
) |
|
| 642 | 24x |
start_ang <- end_ang |
| 643 |
} |
|
| 644 |
} else {
|
|
| 645 |
# No pie values - fill inner with white |
|
| 646 | 1x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 647 | 1x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 648 | 1x |
r = grid::unit(pie_radius, "npc"), |
| 649 | 1x |
gp = grid::gpar(fill = "white", col = NA) |
| 650 |
) |
|
| 651 |
} |
|
| 652 | ||
| 653 |
# 4. Draw borders |
|
| 654 | 11x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 655 | 11x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 656 | 11x |
r = grid::unit(outer_r, "npc"), |
| 657 | 11x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 658 |
) |
|
| 659 | 11x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 660 | 11x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 661 | 11x |
r = grid::unit(inner_r, "npc"), |
| 662 | 11x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 663 |
) |
|
| 664 | ||
| 665 | 11x |
do.call(grid::gList, grobs) |
| 666 |
} |
|
| 667 | ||
| 668 |
#' Draw Double Donut with Inner Pie Node |
|
| 669 |
#' |
|
| 670 |
#' Draw a node with two concentric donut rings and an optional inner pie chart. |
|
| 671 |
#' From outside to inside: outer donut ring, inner donut ring, center pie. |
|
| 672 |
#' |
|
| 673 |
#' @param pie_border_width Border width for pie segments (optional). |
|
| 674 |
#' @param donut_border_width Border width for donut rings (optional). |
|
| 675 |
#' @keywords internal |
|
| 676 |
draw_double_donut_pie <- function(x, y, size, fill, border_color, border_width, |
|
| 677 |
alpha = 1, donut_values = NULL, donut_colors = NULL, |
|
| 678 |
donut2_values = NULL, donut2_colors = NULL, |
|
| 679 |
pie_values = NULL, pie_colors = NULL, |
|
| 680 |
outer_inner_ratio = 0.7, inner_inner_ratio = 0.4, |
|
| 681 |
bg_color = "gray90", pie_border_width = NULL, |
|
| 682 |
donut_border_width = NULL, ...) {
|
|
| 683 | 37x |
fill_col <- adjust_alpha(fill, alpha) |
| 684 | 37x |
border_col <- adjust_alpha(border_color, alpha) |
| 685 | 37x |
bg_col <- adjust_alpha(bg_color, alpha) |
| 686 | ||
| 687 |
# Use specific border widths if provided |
|
| 688 | 37x |
ring_border <- if (!is.null(donut_border_width)) donut_border_width else border_width |
| 689 | 37x |
pie_segment_border <- if (!is.null(pie_border_width)) pie_border_width else border_width * 0.5 |
| 690 | ||
| 691 |
# Define radii for the three layers |
|
| 692 | 37x |
outer_r <- size |
| 693 | 37x |
mid_r <- size * outer_inner_ratio |
| 694 | 37x |
inner_r <- size * inner_inner_ratio |
| 695 | ||
| 696 | 37x |
grobs <- list() |
| 697 | ||
| 698 |
# Get viewport dimensions for aspect ratio correction |
|
| 699 | 37x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 700 | 37x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 701 | 37x |
min_dim <- min(vp_width, vp_height) |
| 702 | 37x |
x_scale <- min_dim / vp_width |
| 703 | 37x |
y_scale <- min_dim / vp_height |
| 704 | ||
| 705 |
# Helper function for ring coordinates |
|
| 706 | 37x |
make_ring_coords <- function(start_ang, end_ang, r_outer, r_inner, cx, cy, n_pts = 100) {
|
| 707 | 148x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 708 | 148x |
outer_x <- cx + (r_outer * x_scale) * cos(angles) |
| 709 | 148x |
outer_y <- cy + (r_outer * y_scale) * sin(angles) |
| 710 | 148x |
inner_x <- cx + (r_inner * x_scale) * cos(rev(angles)) |
| 711 | 148x |
inner_y <- cy + (r_inner * y_scale) * sin(rev(angles)) |
| 712 | 148x |
list(x = c(outer_x, inner_x), y = c(outer_y, inner_y)) |
| 713 |
} |
|
| 714 | ||
| 715 |
# Helper function for pie slice coordinates |
|
| 716 | 37x |
make_pie_coords <- function(start_ang, end_ang, radius, cx, cy, n_pts = 50) {
|
| 717 | 61x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 718 | 61x |
xs <- c(cx, cx + (radius * x_scale) * cos(angles), cx) |
| 719 | 61x |
ys <- c(cy, cy + (radius * y_scale) * sin(angles), cy) |
| 720 | 61x |
list(x = xs, y = ys) |
| 721 |
} |
|
| 722 | ||
| 723 | 37x |
inset <- 0.97 |
| 724 | ||
| 725 |
# Helper to draw donut ring (handles both progress and segmented) |
|
| 726 | 37x |
draw_donut_ring_grid <- function(values, colors, r_outer, r_inner) {
|
| 727 | 74x |
if (is.null(values)) {
|
| 728 |
# Fill with background |
|
| 729 | 2x |
bg_coords <- make_ring_coords(0, 2 * pi, r_outer * inset, r_inner / inset, x, y, 200) |
| 730 | 2x |
return(list(grid::polygonGrob( |
| 731 | 2x |
x = grid::unit(bg_coords$x, "npc"), |
| 732 | 2x |
y = grid::unit(bg_coords$y, "npc"), |
| 733 | 2x |
gp = grid::gpar(fill = bg_col, col = NA) |
| 734 |
))) |
|
| 735 |
} |
|
| 736 | ||
| 737 | 72x |
ring_grobs <- list() |
| 738 | ||
| 739 | 72x |
if (length(values) == 1) {
|
| 740 |
# Progress donut - draw background then filled portion |
|
| 741 | 69x |
bg_coords <- make_ring_coords(0, 2 * pi, r_outer * inset, r_inner / inset, x, y, 200) |
| 742 | 69x |
ring_grobs[[length(ring_grobs) + 1]] <- grid::polygonGrob( |
| 743 | 69x |
x = grid::unit(bg_coords$x, "npc"), |
| 744 | 69x |
y = grid::unit(bg_coords$y, "npc"), |
| 745 | 69x |
gp = grid::gpar(fill = bg_col, col = NA) |
| 746 |
) |
|
| 747 | ||
| 748 | 69x |
prop <- max(0, min(1, values)) |
| 749 | 69x |
if (prop > 0) {
|
| 750 | 69x |
fill_c <- if (!is.null(colors)) adjust_alpha(colors[1], alpha) else fill_col |
| 751 | 69x |
start_ang <- pi / 2 |
| 752 | 69x |
end_ang <- pi / 2 - 2 * pi * prop |
| 753 | 69x |
n_pts <- max(100, ceiling(300 * prop)) |
| 754 | 69x |
fill_coords <- make_ring_coords(start_ang, end_ang, r_outer * inset, r_inner / inset, x, y, n_pts) |
| 755 | 69x |
ring_grobs[[length(ring_grobs) + 1]] <- grid::polygonGrob( |
| 756 | 69x |
x = grid::unit(fill_coords$x, "npc"), |
| 757 | 69x |
y = grid::unit(fill_coords$y, "npc"), |
| 758 | 69x |
gp = grid::gpar(fill = fill_c, col = NA) |
| 759 |
) |
|
| 760 |
} |
|
| 761 |
} else {
|
|
| 762 |
# Segmented donut |
|
| 763 | 3x |
props <- values / sum(values) |
| 764 | ||
| 765 | 3x |
if (is.null(colors)) {
|
| 766 | 1x |
colors <- grDevices::rainbow(length(values), alpha = alpha) |
| 767 |
} else {
|
|
| 768 | 2x |
colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 769 | 2x |
colors <- rep(colors, length.out = length(values)) |
| 770 |
} |
|
| 771 | ||
| 772 | 3x |
start_ang <- pi / 2 |
| 773 | 3x |
for (i in seq_along(props)) {
|
| 774 | 8x |
end_ang <- start_ang - 2 * pi * props[i] |
| 775 | 8x |
n_pts <- max(50, ceiling(150 * props[i])) |
| 776 | 8x |
seg_coords <- make_ring_coords(start_ang, end_ang, r_outer * inset, r_inner / inset, x, y, n_pts) |
| 777 | 8x |
ring_grobs[[length(ring_grobs) + 1]] <- grid::polygonGrob( |
| 778 | 8x |
x = grid::unit(seg_coords$x, "npc"), |
| 779 | 8x |
y = grid::unit(seg_coords$y, "npc"), |
| 780 | 8x |
gp = grid::gpar(fill = colors[i], col = NA) |
| 781 |
) |
|
| 782 | 8x |
start_ang <- end_ang |
| 783 |
} |
|
| 784 |
} |
|
| 785 | ||
| 786 | 72x |
ring_grobs |
| 787 |
} |
|
| 788 | ||
| 789 |
# 1. Draw outer donut ring |
|
| 790 | 37x |
grobs <- c(grobs, draw_donut_ring_grid(donut_values, donut_colors, outer_r, mid_r)) |
| 791 | ||
| 792 |
# 2. Draw inner donut ring |
|
| 793 | 37x |
grobs <- c(grobs, draw_donut_ring_grid(donut2_values, donut2_colors, mid_r, inner_r)) |
| 794 | ||
| 795 |
# 3. Draw center pie (if values provided) |
|
| 796 | 37x |
pie_radius <- inner_r * 0.95 |
| 797 | 37x |
if (!is.null(pie_values) && length(pie_values) > 0) {
|
| 798 | 30x |
props <- pie_values / sum(pie_values) |
| 799 | ||
| 800 | 30x |
if (is.null(pie_colors)) {
|
| 801 | 2x |
pie_colors <- grDevices::rainbow(length(pie_values), alpha = alpha) |
| 802 |
} else {
|
|
| 803 | 28x |
pie_colors <- sapply(pie_colors, adjust_alpha, alpha = alpha) |
| 804 | 28x |
pie_colors <- rep(pie_colors, length.out = length(pie_values)) |
| 805 |
} |
|
| 806 | ||
| 807 | 30x |
start_ang <- pi / 2 |
| 808 | 30x |
for (i in seq_along(props)) {
|
| 809 | 61x |
end_ang <- start_ang - 2 * pi * props[i] |
| 810 | 61x |
n_pts <- max(30, ceiling(100 * props[i])) |
| 811 | 61x |
pie_coords <- make_pie_coords(start_ang, end_ang, pie_radius, x, y, n_pts) |
| 812 | 61x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 813 | 61x |
x = grid::unit(pie_coords$x, "npc"), |
| 814 | 61x |
y = grid::unit(pie_coords$y, "npc"), |
| 815 | 61x |
gp = grid::gpar(fill = pie_colors[i], col = NA) |
| 816 |
) |
|
| 817 | 61x |
start_ang <- end_ang |
| 818 |
} |
|
| 819 |
} else {
|
|
| 820 |
# No pie values - fill inner with white |
|
| 821 | 7x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 822 | 7x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 823 | 7x |
r = grid::unit(pie_radius, "npc"), |
| 824 | 7x |
gp = grid::gpar(fill = "white", col = NA) |
| 825 |
) |
|
| 826 |
} |
|
| 827 | ||
| 828 |
# 4. Draw all borders |
|
| 829 |
# Outer border |
|
| 830 | 37x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 831 | 37x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 832 | 37x |
r = grid::unit(outer_r, "npc"), |
| 833 | 37x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 834 |
) |
|
| 835 |
# Middle border (between outer and inner donut) |
|
| 836 | 37x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 837 | 37x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 838 | 37x |
r = grid::unit(mid_r, "npc"), |
| 839 | 37x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 840 |
) |
|
| 841 |
# Inner border (between inner donut and pie) |
|
| 842 | 37x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 843 | 37x |
x = grid::unit(x, "npc"), y = grid::unit(y, "npc"), |
| 844 | 37x |
r = grid::unit(inner_r, "npc"), |
| 845 | 37x |
gp = grid::gpar(fill = NA, col = border_col, lwd = ring_border) |
| 846 |
) |
|
| 847 | ||
| 848 | 37x |
do.call(grid::gList, grobs) |
| 849 |
} |
|
| 850 | ||
| 851 |
#' Draw Neural Node |
|
| 852 |
#' |
|
| 853 |
#' Circle with small connection circles around the perimeter (neuron-like). |
|
| 854 |
#' |
|
| 855 |
#' @param n_connections Number of connection points around perimeter. |
|
| 856 |
#' @keywords internal |
|
| 857 |
draw_neural <- function(x, y, size, fill, border_color, border_width, |
|
| 858 |
alpha = 1, n_connections = 6, ...) {
|
|
| 859 | 16x |
fill_col <- adjust_alpha(fill, alpha) |
| 860 | 16x |
border_col <- adjust_alpha(border_color, alpha) |
| 861 | ||
| 862 |
# Get viewport dimensions for aspect correction |
|
| 863 | 16x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 864 | 16x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 865 | 16x |
min_dim <- min(vp_width, vp_height) |
| 866 | 16x |
x_scale <- min_dim / vp_width |
| 867 | 16x |
y_scale <- min_dim / vp_height |
| 868 | ||
| 869 | 16x |
grobs <- list() |
| 870 | ||
| 871 |
# Main center circle |
|
| 872 | 16x |
grobs[[1]] <- grid::circleGrob( |
| 873 | 16x |
x = grid::unit(x, "npc"), |
| 874 | 16x |
y = grid::unit(y, "npc"), |
| 875 | 16x |
r = grid::unit(size * 0.6, "npc"), |
| 876 | 16x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 877 |
) |
|
| 878 | ||
| 879 |
# Connection circles around perimeter |
|
| 880 | 16x |
conn_radius <- size * 0.15 |
| 881 | 16x |
angles <- seq(0, 2 * pi * (1 - 1/n_connections), length.out = n_connections) |
| 882 | ||
| 883 | 16x |
for (i in seq_along(angles)) {
|
| 884 | 96x |
cx <- x + (size * 0.85 * x_scale) * cos(angles[i]) |
| 885 | 96x |
cy <- y + (size * 0.85 * y_scale) * sin(angles[i]) |
| 886 | ||
| 887 |
# Line from center to connection |
|
| 888 | 96x |
grobs[[length(grobs) + 1]] <- grid::segmentsGrob( |
| 889 | 96x |
x0 = grid::unit(x, "npc"), |
| 890 | 96x |
y0 = grid::unit(y, "npc"), |
| 891 | 96x |
x1 = grid::unit(cx, "npc"), |
| 892 | 96x |
y1 = grid::unit(cy, "npc"), |
| 893 | 96x |
gp = grid::gpar(col = border_col, lwd = border_width * 0.5) |
| 894 |
) |
|
| 895 | ||
| 896 |
# Connection circle |
|
| 897 | 96x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 898 | 96x |
x = grid::unit(cx, "npc"), |
| 899 | 96x |
y = grid::unit(cy, "npc"), |
| 900 | 96x |
r = grid::unit(conn_radius, "npc"), |
| 901 | 96x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width * 0.7) |
| 902 |
) |
|
| 903 |
} |
|
| 904 | ||
| 905 | 16x |
do.call(grid::gList, grobs) |
| 906 |
} |
|
| 907 | ||
| 908 |
#' Draw Chip Node |
|
| 909 |
#' |
|
| 910 |
#' Square with pins extending from all edges (processor/IC chip). |
|
| 911 |
#' |
|
| 912 |
#' @param pins_per_side Number of pins per side. |
|
| 913 |
#' @keywords internal |
|
| 914 |
draw_chip <- function(x, y, size, fill, border_color, border_width, |
|
| 915 |
alpha = 1, pins_per_side = 3, ...) {
|
|
| 916 | 16x |
fill_col <- adjust_alpha(fill, alpha) |
| 917 | 16x |
border_col <- adjust_alpha(border_color, alpha) |
| 918 | ||
| 919 | 16x |
grobs <- list() |
| 920 | ||
| 921 |
# Main body (square with corner notch) |
|
| 922 | 16x |
body_size <- size * 0.7 |
| 923 | 16x |
notch_size <- body_size * 0.15 |
| 924 | ||
| 925 |
# Create notched square polygon |
|
| 926 | 16x |
xs <- c( |
| 927 | 16x |
x - body_size, x - body_size + notch_size, x + body_size, x + body_size, x - body_size |
| 928 |
) |
|
| 929 | 16x |
ys <- c( |
| 930 | 16x |
y - body_size, y + body_size, y + body_size, y - body_size, y - body_size |
| 931 |
) |
|
| 932 | ||
| 933 | 16x |
grobs[[1]] <- grid::polygonGrob( |
| 934 | 16x |
x = grid::unit(xs, "npc"), |
| 935 | 16x |
y = grid::unit(ys, "npc"), |
| 936 | 16x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 937 |
) |
|
| 938 | ||
| 939 |
# Draw pins on each side |
|
| 940 | 16x |
pin_length <- size * 0.2 |
| 941 | 16x |
pin_width <- body_size * 0.8 / (pins_per_side * 2 - 1) |
| 942 | ||
| 943 |
# Helper to draw pins |
|
| 944 | 16x |
draw_pins <- function(side) {
|
| 945 | 64x |
pin_grobs <- list() |
| 946 | 64x |
for (i in seq_len(pins_per_side)) {
|
| 947 | 196x |
offset <- (i - (pins_per_side + 1) / 2) * (body_size * 1.5 / pins_per_side) |
| 948 | ||
| 949 | 196x |
if (side == "top") {
|
| 950 | 49x |
px <- x + offset |
| 951 | 49x |
py <- y + body_size |
| 952 | 49x |
p_xs <- c(px - pin_width/2, px + pin_width/2, px + pin_width/2, px - pin_width/2) |
| 953 | 49x |
p_ys <- c(py, py, py + pin_length, py + pin_length) |
| 954 | 147x |
} else if (side == "bottom") {
|
| 955 | 49x |
px <- x + offset |
| 956 | 49x |
py <- y - body_size |
| 957 | 49x |
p_xs <- c(px - pin_width/2, px + pin_width/2, px + pin_width/2, px - pin_width/2) |
| 958 | 49x |
p_ys <- c(py, py, py - pin_length, py - pin_length) |
| 959 | 98x |
} else if (side == "left") {
|
| 960 | 49x |
px <- x - body_size |
| 961 | 49x |
py <- y + offset |
| 962 | 49x |
p_xs <- c(px, px, px - pin_length, px - pin_length) |
| 963 | 49x |
p_ys <- c(py - pin_width/2, py + pin_width/2, py + pin_width/2, py - pin_width/2) |
| 964 | 16x |
} else { # right
|
| 965 | 49x |
px <- x + body_size |
| 966 | 49x |
py <- y + offset |
| 967 | 49x |
p_xs <- c(px, px, px + pin_length, px + pin_length) |
| 968 | 49x |
p_ys <- c(py - pin_width/2, py + pin_width/2, py + pin_width/2, py - pin_width/2) |
| 969 |
} |
|
| 970 | ||
| 971 | 196x |
pin_grobs[[i]] <- grid::polygonGrob( |
| 972 | 196x |
x = grid::unit(p_xs, "npc"), |
| 973 | 196x |
y = grid::unit(p_ys, "npc"), |
| 974 | 196x |
gp = grid::gpar(fill = border_col, col = border_col, lwd = 0.5) |
| 975 |
) |
|
| 976 |
} |
|
| 977 | 64x |
pin_grobs |
| 978 |
} |
|
| 979 | ||
| 980 | 16x |
grobs <- c(grobs, draw_pins("top"), draw_pins("bottom"),
|
| 981 | 16x |
draw_pins("left"), draw_pins("right"))
|
| 982 | ||
| 983 | 16x |
do.call(grid::gList, grobs) |
| 984 |
} |
|
| 985 | ||
| 986 |
#' Draw Robot Node |
|
| 987 |
#' |
|
| 988 |
#' Rounded square with antenna and eyes (robot head). |
|
| 989 |
#' |
|
| 990 |
#' @keywords internal |
|
| 991 |
draw_robot <- function(x, y, size, fill, border_color, border_width, |
|
| 992 |
alpha = 1, ...) {
|
|
| 993 | 14x |
fill_col <- adjust_alpha(fill, alpha) |
| 994 | 14x |
border_col <- adjust_alpha(border_color, alpha) |
| 995 | ||
| 996 | 14x |
grobs <- list() |
| 997 | ||
| 998 |
# Robot head (rounded rectangle) |
|
| 999 | 14x |
head_w <- size * 0.8 |
| 1000 | 14x |
head_h <- size * 0.7 |
| 1001 | ||
| 1002 | 14x |
grobs[[1]] <- grid::roundrectGrob( |
| 1003 | 14x |
x = grid::unit(x, "npc"), |
| 1004 | 14x |
y = grid::unit(y - size * 0.1, "npc"), |
| 1005 | 14x |
width = grid::unit(head_w * 2, "npc"), |
| 1006 | 14x |
height = grid::unit(head_h * 2, "npc"), |
| 1007 | 14x |
r = grid::unit(0.2, "npc"), |
| 1008 | 14x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1009 |
) |
|
| 1010 | ||
| 1011 |
# Antenna stem |
|
| 1012 | 14x |
antenna_base_y <- y + head_h - size * 0.1 |
| 1013 | 14x |
grobs[[2]] <- grid::segmentsGrob( |
| 1014 | 14x |
x0 = grid::unit(x, "npc"), |
| 1015 | 14x |
y0 = grid::unit(antenna_base_y, "npc"), |
| 1016 | 14x |
x1 = grid::unit(x, "npc"), |
| 1017 | 14x |
y1 = grid::unit(y + size, "npc"), |
| 1018 | 14x |
gp = grid::gpar(col = border_col, lwd = border_width) |
| 1019 |
) |
|
| 1020 | ||
| 1021 |
# Antenna ball |
|
| 1022 | 14x |
grobs[[3]] <- grid::circleGrob( |
| 1023 | 14x |
x = grid::unit(x, "npc"), |
| 1024 | 14x |
y = grid::unit(y + size + size * 0.08, "npc"), |
| 1025 | 14x |
r = grid::unit(size * 0.08, "npc"), |
| 1026 | 14x |
gp = grid::gpar(fill = border_col, col = border_col) |
| 1027 |
) |
|
| 1028 | ||
| 1029 |
# Eyes (two circles) |
|
| 1030 | 14x |
eye_y <- y |
| 1031 | 14x |
eye_radius <- size * 0.12 |
| 1032 | ||
| 1033 | 14x |
grobs[[4]] <- grid::circleGrob( |
| 1034 | 14x |
x = grid::unit(x - head_w * 0.4, "npc"), |
| 1035 | 14x |
y = grid::unit(eye_y, "npc"), |
| 1036 | 14x |
r = grid::unit(eye_radius, "npc"), |
| 1037 | 14x |
gp = grid::gpar(fill = "white", col = border_col, lwd = border_width * 0.7) |
| 1038 |
) |
|
| 1039 | ||
| 1040 | 14x |
grobs[[5]] <- grid::circleGrob( |
| 1041 | 14x |
x = grid::unit(x + head_w * 0.4, "npc"), |
| 1042 | 14x |
y = grid::unit(eye_y, "npc"), |
| 1043 | 14x |
r = grid::unit(eye_radius, "npc"), |
| 1044 | 14x |
gp = grid::gpar(fill = "white", col = border_col, lwd = border_width * 0.7) |
| 1045 |
) |
|
| 1046 | ||
| 1047 |
# Mouth (horizontal line) |
|
| 1048 | 14x |
grobs[[6]] <- grid::segmentsGrob( |
| 1049 | 14x |
x0 = grid::unit(x - head_w * 0.3, "npc"), |
| 1050 | 14x |
y0 = grid::unit(y - head_h * 0.4, "npc"), |
| 1051 | 14x |
x1 = grid::unit(x + head_w * 0.3, "npc"), |
| 1052 | 14x |
y1 = grid::unit(y - head_h * 0.4, "npc"), |
| 1053 | 14x |
gp = grid::gpar(col = border_col, lwd = border_width) |
| 1054 |
) |
|
| 1055 | ||
| 1056 | 14x |
do.call(grid::gList, grobs) |
| 1057 |
} |
|
| 1058 | ||
| 1059 |
#' Draw Brain Node |
|
| 1060 |
#' |
|
| 1061 |
#' Simplified brain outline using overlapping curves. |
|
| 1062 |
#' |
|
| 1063 |
#' @keywords internal |
|
| 1064 |
draw_brain <- function(x, y, size, fill, border_color, border_width, |
|
| 1065 |
alpha = 1, ...) {
|
|
| 1066 | 14x |
fill_col <- adjust_alpha(fill, alpha) |
| 1067 | 14x |
border_col <- adjust_alpha(border_color, alpha) |
| 1068 | ||
| 1069 |
# Brain shape using overlapping lobes |
|
| 1070 | 14x |
n_pts <- 80 |
| 1071 | 14x |
t <- seq(0, 2 * pi, length.out = n_pts) |
| 1072 | ||
| 1073 |
# Create irregular brain-like shape |
|
| 1074 | 14x |
r <- size * (0.7 + 0.15 * sin(3 * t) + 0.1 * sin(5 * t) + 0.05 * cos(7 * t)) |
| 1075 | 14x |
xs <- x + r * cos(t) |
| 1076 | 14x |
ys <- y + r * sin(t) * 0.85 # Slightly flattened |
| 1077 | ||
| 1078 | 14x |
grobs <- list() |
| 1079 | ||
| 1080 |
# Main brain shape |
|
| 1081 | 14x |
grobs[[1]] <- grid::polygonGrob( |
| 1082 | 14x |
x = grid::unit(xs, "npc"), |
| 1083 | 14x |
y = grid::unit(ys, "npc"), |
| 1084 | 14x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1085 |
) |
|
| 1086 | ||
| 1087 |
# Central fissure (dividing line) |
|
| 1088 | 14x |
grobs[[2]] <- grid::segmentsGrob( |
| 1089 | 14x |
x0 = grid::unit(x, "npc"), |
| 1090 | 14x |
y0 = grid::unit(y + size * 0.6, "npc"), |
| 1091 | 14x |
x1 = grid::unit(x, "npc"), |
| 1092 | 14x |
y1 = grid::unit(y - size * 0.5, "npc"), |
| 1093 | 14x |
gp = grid::gpar(col = border_col, lwd = border_width * 0.5) |
| 1094 |
) |
|
| 1095 | ||
| 1096 | 14x |
do.call(grid::gList, grobs) |
| 1097 |
} |
|
| 1098 | ||
| 1099 |
#' Draw Network Node |
|
| 1100 |
#' |
|
| 1101 |
#' Interconnected nodes pattern (mini network inside). |
|
| 1102 |
#' |
|
| 1103 |
#' @keywords internal |
|
| 1104 |
draw_network <- function(x, y, size, fill, border_color, border_width, |
|
| 1105 |
alpha = 1, ...) {
|
|
| 1106 | 11x |
fill_col <- adjust_alpha(fill, alpha) |
| 1107 | 11x |
border_col <- adjust_alpha(border_color, alpha) |
| 1108 | ||
| 1109 |
# Get viewport dimensions for aspect correction |
|
| 1110 | 11x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 1111 | 11x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 1112 | 11x |
min_dim <- min(vp_width, vp_height) |
| 1113 | 11x |
x_scale <- min_dim / vp_width |
| 1114 | 11x |
y_scale <- min_dim / vp_height |
| 1115 | ||
| 1116 | 11x |
grobs <- list() |
| 1117 | ||
| 1118 |
# Outer boundary circle |
|
| 1119 | 11x |
grobs[[1]] <- grid::circleGrob( |
| 1120 | 11x |
x = grid::unit(x, "npc"), |
| 1121 | 11x |
y = grid::unit(y, "npc"), |
| 1122 | 11x |
r = grid::unit(size, "npc"), |
| 1123 | 11x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1124 |
) |
|
| 1125 | ||
| 1126 |
# Mini nodes inside (pentagon arrangement) |
|
| 1127 | 11x |
n_nodes <- 5 |
| 1128 | 11x |
inner_r <- size * 0.55 |
| 1129 | 11x |
node_r <- size * 0.12 |
| 1130 | 11x |
angles <- seq(pi/2, pi/2 + 2 * pi * (1 - 1/n_nodes), length.out = n_nodes) |
| 1131 | ||
| 1132 | 11x |
node_x <- x + (inner_r * x_scale) * cos(angles) |
| 1133 | 11x |
node_y <- y + (inner_r * y_scale) * sin(angles) |
| 1134 | ||
| 1135 |
# Draw edges between nodes |
|
| 1136 | 11x |
for (i in seq_len(n_nodes)) {
|
| 1137 | 55x |
for (j in seq_len(n_nodes)) {
|
| 1138 | 275x |
if (i < j) {
|
| 1139 | 110x |
grobs[[length(grobs) + 1]] <- grid::segmentsGrob( |
| 1140 | 110x |
x0 = grid::unit(node_x[i], "npc"), |
| 1141 | 110x |
y0 = grid::unit(node_y[i], "npc"), |
| 1142 | 110x |
x1 = grid::unit(node_x[j], "npc"), |
| 1143 | 110x |
y1 = grid::unit(node_y[j], "npc"), |
| 1144 | 110x |
gp = grid::gpar(col = border_col, lwd = border_width * 0.5) |
| 1145 |
) |
|
| 1146 |
} |
|
| 1147 |
} |
|
| 1148 |
} |
|
| 1149 | ||
| 1150 |
# Draw mini nodes |
|
| 1151 | 11x |
for (i in seq_len(n_nodes)) {
|
| 1152 | 55x |
grobs[[length(grobs) + 1]] <- grid::circleGrob( |
| 1153 | 55x |
x = grid::unit(node_x[i], "npc"), |
| 1154 | 55x |
y = grid::unit(node_y[i], "npc"), |
| 1155 | 55x |
r = grid::unit(node_r, "npc"), |
| 1156 | 55x |
gp = grid::gpar(fill = "white", col = border_col, lwd = border_width * 0.7) |
| 1157 |
) |
|
| 1158 |
} |
|
| 1159 | ||
| 1160 | 11x |
do.call(grid::gList, grobs) |
| 1161 |
} |
|
| 1162 | ||
| 1163 |
#' Draw Database Node |
|
| 1164 |
#' |
|
| 1165 |
#' Cylinder shape (data storage). |
|
| 1166 |
#' |
|
| 1167 |
#' @keywords internal |
|
| 1168 |
draw_database <- function(x, y, size, fill, border_color, border_width, |
|
| 1169 |
alpha = 1, ...) {
|
|
| 1170 | 14x |
fill_col <- adjust_alpha(fill, alpha) |
| 1171 | 14x |
border_col <- adjust_alpha(border_color, alpha) |
| 1172 | ||
| 1173 | 14x |
grobs <- list() |
| 1174 | ||
| 1175 | 14x |
cyl_width <- size * 0.8 |
| 1176 | 14x |
cyl_height <- size * 1.2 |
| 1177 | 14x |
ellipse_h <- size * 0.25 |
| 1178 | ||
| 1179 | 14x |
n_pts <- 50 |
| 1180 | 14x |
angles <- seq(0, pi, length.out = n_pts) |
| 1181 | 14x |
angles_full <- seq(0, 2 * pi, length.out = n_pts * 2) |
| 1182 | ||
| 1183 |
# Bottom ellipse |
|
| 1184 | 14x |
bottom_y <- y - cyl_height / 2 |
| 1185 | ||
| 1186 |
# Cylinder body (rectangle) |
|
| 1187 | 14x |
body_xs <- c(x - cyl_width, x + cyl_width, x + cyl_width, x - cyl_width) |
| 1188 | 14x |
body_ys <- c(bottom_y, bottom_y, y + cyl_height / 2, y + cyl_height / 2) |
| 1189 | ||
| 1190 | 14x |
grobs[[1]] <- grid::polygonGrob( |
| 1191 | 14x |
x = grid::unit(body_xs, "npc"), |
| 1192 | 14x |
y = grid::unit(body_ys, "npc"), |
| 1193 | 14x |
gp = grid::gpar(fill = fill_col, col = NA) |
| 1194 |
) |
|
| 1195 | ||
| 1196 |
# Bottom ellipse (lower half visible) |
|
| 1197 | 14x |
bottom_x <- x + cyl_width * cos(angles) |
| 1198 | 14x |
bottom_y_pts <- bottom_y + ellipse_h * sin(angles) * (-1) |
| 1199 | ||
| 1200 | 14x |
grobs[[2]] <- grid::linesGrob( |
| 1201 | 14x |
x = grid::unit(bottom_x, "npc"), |
| 1202 | 14x |
y = grid::unit(bottom_y_pts, "npc"), |
| 1203 | 14x |
gp = grid::gpar(col = border_col, lwd = border_width) |
| 1204 |
) |
|
| 1205 | ||
| 1206 |
# Top ellipse (full) |
|
| 1207 | 14x |
top_y <- y + cyl_height / 2 |
| 1208 | 14x |
top_x <- x + cyl_width * cos(angles_full) |
| 1209 | 14x |
top_y_pts <- top_y + ellipse_h * sin(angles_full) |
| 1210 | ||
| 1211 | 14x |
grobs[[3]] <- grid::polygonGrob( |
| 1212 | 14x |
x = grid::unit(top_x, "npc"), |
| 1213 | 14x |
y = grid::unit(top_y_pts, "npc"), |
| 1214 | 14x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1215 |
) |
|
| 1216 | ||
| 1217 |
# Side lines |
|
| 1218 | 14x |
grobs[[4]] <- grid::segmentsGrob( |
| 1219 | 14x |
x0 = grid::unit(x - cyl_width, "npc"), |
| 1220 | 14x |
y0 = grid::unit(bottom_y, "npc"), |
| 1221 | 14x |
x1 = grid::unit(x - cyl_width, "npc"), |
| 1222 | 14x |
y1 = grid::unit(y + cyl_height / 2, "npc"), |
| 1223 | 14x |
gp = grid::gpar(col = border_col, lwd = border_width) |
| 1224 |
) |
|
| 1225 | ||
| 1226 | 14x |
grobs[[5]] <- grid::segmentsGrob( |
| 1227 | 14x |
x0 = grid::unit(x + cyl_width, "npc"), |
| 1228 | 14x |
y0 = grid::unit(bottom_y, "npc"), |
| 1229 | 14x |
x1 = grid::unit(x + cyl_width, "npc"), |
| 1230 | 14x |
y1 = grid::unit(y + cyl_height / 2, "npc"), |
| 1231 | 14x |
gp = grid::gpar(col = border_col, lwd = border_width) |
| 1232 |
) |
|
| 1233 | ||
| 1234 | 14x |
do.call(grid::gList, grobs) |
| 1235 |
} |
|
| 1236 | ||
| 1237 |
#' Draw Cloud Node |
|
| 1238 |
#' |
|
| 1239 |
#' Cloud shape (cloud computing). |
|
| 1240 |
#' |
|
| 1241 |
#' @keywords internal |
|
| 1242 |
draw_cloud <- function(x, y, size, fill, border_color, border_width, |
|
| 1243 |
alpha = 1, ...) {
|
|
| 1244 | 14x |
fill_col <- adjust_alpha(fill, alpha) |
| 1245 | 14x |
border_col <- adjust_alpha(border_color, alpha) |
| 1246 | ||
| 1247 |
# Cloud made of overlapping circles |
|
| 1248 | 14x |
n_pts <- 100 |
| 1249 | 14x |
t <- seq(0, 2 * pi, length.out = n_pts) |
| 1250 | ||
| 1251 |
# Bumpy cloud shape |
|
| 1252 | 14x |
r <- size * (0.65 + 0.2 * sin(4 * t) + 0.1 * sin(6 * t)) |
| 1253 | 14x |
xs <- x + r * cos(t) |
| 1254 | 14x |
ys <- y + r * sin(t) * 0.6 + size * 0.1 # Flattened and raised |
| 1255 | ||
| 1256 | 14x |
grid::polygonGrob( |
| 1257 | 14x |
x = grid::unit(xs, "npc"), |
| 1258 | 14x |
y = grid::unit(ys, "npc"), |
| 1259 | 14x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1260 |
) |
|
| 1261 |
} |
|
| 1262 | ||
| 1263 |
#' Draw Gear Node |
|
| 1264 |
#' |
|
| 1265 |
#' Gear/cog shape (processing/automation). |
|
| 1266 |
#' |
|
| 1267 |
#' @param n_teeth Number of gear teeth. |
|
| 1268 |
#' @keywords internal |
|
| 1269 |
draw_gear <- function(x, y, size, fill, border_color, border_width, |
|
| 1270 |
alpha = 1, n_teeth = 8, ...) {
|
|
| 1271 | 16x |
fill_col <- adjust_alpha(fill, alpha) |
| 1272 | 16x |
border_col <- adjust_alpha(border_color, alpha) |
| 1273 | ||
| 1274 | 16x |
grobs <- list() |
| 1275 | ||
| 1276 |
# Gear parameters |
|
| 1277 | 16x |
outer_r <- size |
| 1278 | 16x |
inner_r <- size * 0.65 |
| 1279 | 16x |
tooth_height <- size * 0.25 |
| 1280 | 16x |
center_r <- size * 0.25 |
| 1281 | ||
| 1282 |
# Generate gear teeth |
|
| 1283 | 16x |
n_pts_per_tooth <- 8 |
| 1284 | 16x |
n_total <- n_teeth * n_pts_per_tooth |
| 1285 | 16x |
angles <- seq(0, 2 * pi, length.out = n_total + 1)[-1] |
| 1286 | ||
| 1287 | 16x |
gear_x <- numeric(n_total) |
| 1288 | 16x |
gear_y <- numeric(n_total) |
| 1289 | ||
| 1290 | 16x |
for (i in seq_len(n_total)) {
|
| 1291 | 1040x |
tooth_idx <- (i - 1) %/% n_pts_per_tooth |
| 1292 | 1040x |
pos_in_tooth <- (i - 1) %% n_pts_per_tooth |
| 1293 | ||
| 1294 | 1040x |
if (pos_in_tooth < 2 || pos_in_tooth >= 6) {
|
| 1295 |
# Valley |
|
| 1296 | 520x |
r <- inner_r |
| 1297 |
} else {
|
|
| 1298 |
# Tooth |
|
| 1299 | 520x |
r <- inner_r + tooth_height |
| 1300 |
} |
|
| 1301 | ||
| 1302 | 1040x |
gear_x[i] <- x + r * cos(angles[i]) |
| 1303 | 1040x |
gear_y[i] <- y + r * sin(angles[i]) |
| 1304 |
} |
|
| 1305 | ||
| 1306 |
# Main gear body |
|
| 1307 | 16x |
grobs[[1]] <- grid::polygonGrob( |
| 1308 | 16x |
x = grid::unit(gear_x, "npc"), |
| 1309 | 16x |
y = grid::unit(gear_y, "npc"), |
| 1310 | 16x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1311 |
) |
|
| 1312 | ||
| 1313 |
# Center hole |
|
| 1314 | 16x |
grobs[[2]] <- grid::circleGrob( |
| 1315 | 16x |
x = grid::unit(x, "npc"), |
| 1316 | 16x |
y = grid::unit(y, "npc"), |
| 1317 | 16x |
r = grid::unit(center_r, "npc"), |
| 1318 | 16x |
gp = grid::gpar(fill = "white", col = border_col, lwd = border_width * 0.7) |
| 1319 |
) |
|
| 1320 | ||
| 1321 | 16x |
do.call(grid::gList, grobs) |
| 1322 |
} |
|
| 1323 | ||
| 1324 |
#' Draw Cross/Plus Node |
|
| 1325 |
#' @keywords internal |
|
| 1326 |
draw_cross <- function(x, y, size, fill, border_color, border_width, |
|
| 1327 |
alpha = 1, thickness = 0.3, ...) {
|
|
| 1328 | 14x |
fill_col <- adjust_alpha(fill, alpha) |
| 1329 | 14x |
border_col <- adjust_alpha(border_color, alpha) |
| 1330 | ||
| 1331 |
# Cross shape |
|
| 1332 | 14x |
t <- size * thickness # Half thickness |
| 1333 | 14x |
s <- size # Half size |
| 1334 | ||
| 1335 |
# Horizontal bar |
|
| 1336 | 14x |
xs1 <- c(x - s, x + s, x + s, x - s) |
| 1337 | 14x |
ys1 <- c(y - t, y - t, y + t, y + t) |
| 1338 | ||
| 1339 |
# Vertical bar |
|
| 1340 | 14x |
xs2 <- c(x - t, x + t, x + t, x - t) |
| 1341 | 14x |
ys2 <- c(y - s, y - s, y + s, y + s) |
| 1342 | ||
| 1343 | 14x |
grid::gList( |
| 1344 | 14x |
grid::polygonGrob( |
| 1345 | 14x |
x = grid::unit(xs1, "npc"), |
| 1346 | 14x |
y = grid::unit(ys1, "npc"), |
| 1347 | 14x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1348 |
), |
|
| 1349 | 14x |
grid::polygonGrob( |
| 1350 | 14x |
x = grid::unit(xs2, "npc"), |
| 1351 | 14x |
y = grid::unit(ys2, "npc"), |
| 1352 | 14x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 1353 |
) |
|
| 1354 |
) |
|
| 1355 |
} |
| 1 |
#' @title Base R Node Rendering |
|
| 2 |
#' @description Node drawing functions for splot() using base R graphics. |
|
| 3 |
#' @name splot-nodes |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Draw a Single Node |
|
| 8 |
#' |
|
| 9 |
#' Renders a node at the specified position with given aesthetics. |
|
| 10 |
#' |
|
| 11 |
#' @param x,y Node center coordinates. |
|
| 12 |
#' @param size Node radius in user coordinates. |
|
| 13 |
#' @param size2 Secondary size (for ellipse height). |
|
| 14 |
#' @param shape Node shape name. |
|
| 15 |
#' @param col Fill color. |
|
| 16 |
#' @param border.col Border color. |
|
| 17 |
#' @param border.width Border line width. |
|
| 18 |
#' @param ... Additional parameters. |
|
| 19 |
#' @keywords internal |
|
| 20 |
draw_node_base <- function(x, y, size, size2 = NULL, shape = "circle", |
|
| 21 |
col = "#4A90D9", border.col = "#2C5AA0", |
|
| 22 |
border.width = 1, ...) {
|
|
| 23 | 2x |
if (is.null(size2)) size2 <- size |
| 24 | ||
| 25 | 2385x |
if (shape == "circle") {
|
| 26 |
# Use symbols() for perfect circles |
|
| 27 | 1915x |
graphics::symbols( |
| 28 | 1915x |
x = x, y = y, |
| 29 | 1915x |
circles = size, |
| 30 | 1915x |
inches = FALSE, |
| 31 | 1915x |
add = TRUE, |
| 32 | 1915x |
fg = border.col, |
| 33 | 1915x |
bg = col, |
| 34 | 1915x |
lwd = border.width |
| 35 |
) |
|
| 36 | ||
| 37 | 470x |
} else if (shape == "square") {
|
| 38 |
# Square using rect() |
|
| 39 | 233x |
graphics::rect( |
| 40 | 233x |
xleft = x - size, |
| 41 | 233x |
ybottom = y - size, |
| 42 | 233x |
xright = x + size, |
| 43 | 233x |
ytop = y + size, |
| 44 | 233x |
col = col, |
| 45 | 233x |
border = border.col, |
| 46 | 233x |
lwd = border.width |
| 47 |
) |
|
| 48 | ||
| 49 | 237x |
} else if (shape == "rectangle" || shape == "ellipse") {
|
| 50 |
# Use polygon for ellipse/rectangle |
|
| 51 | 18x |
verts <- get_shape_vertices(shape, x, y, size, size2) |
| 52 | 18x |
graphics::polygon( |
| 53 | 18x |
x = verts$x, |
| 54 | 18x |
y = verts$y, |
| 55 | 18x |
col = col, |
| 56 | 18x |
border = border.col, |
| 57 | 18x |
lwd = border.width |
| 58 |
) |
|
| 59 | ||
| 60 | 219x |
} else if (shape == "neural") {
|
| 61 | 6x |
draw_neural_node_base(x, y, size, col, border.col, border.width, ...) |
| 62 | ||
| 63 | 213x |
} else if (shape == "chip") {
|
| 64 | 6x |
draw_chip_node_base(x, y, size, col, border.col, border.width, ...) |
| 65 | ||
| 66 | 207x |
} else if (shape == "robot") {
|
| 67 | 6x |
draw_robot_node_base(x, y, size, col, border.col, border.width) |
| 68 | ||
| 69 | 201x |
} else if (shape == "network") {
|
| 70 | 6x |
draw_network_node_base(x, y, size, col, border.col, border.width) |
| 71 | ||
| 72 | 195x |
} else if (shape == "database") {
|
| 73 | 6x |
draw_database_node_base(x, y, size, col, border.col, border.width) |
| 74 | ||
| 75 | 189x |
} else if (!is.null(get_svg_shape(shape))) {
|
| 76 |
# Custom SVG shape (registered with register_svg_shape) |
|
| 77 | 7x |
svg_data <- get_svg_shape(shape) |
| 78 | 7x |
draw_svg_shape_base(x, y, size, svg_data, col, border.col, border.width) |
| 79 | ||
| 80 |
} else {
|
|
| 81 |
# All other shapes via polygon (including gear, cloud, brain) |
|
| 82 | 182x |
verts <- get_shape_vertices(shape, x, y, size, size2, ...) |
| 83 | 182x |
graphics::polygon( |
| 84 | 182x |
x = verts$x, |
| 85 | 182x |
y = verts$y, |
| 86 | 182x |
col = col, |
| 87 | 182x |
border = border.col, |
| 88 | 182x |
lwd = border.width |
| 89 |
) |
|
| 90 |
} |
|
| 91 |
} |
|
| 92 | ||
| 93 |
#' Draw Pie Chart Node |
|
| 94 |
#' |
|
| 95 |
#' Renders a node as a pie chart with multiple colored segments. |
|
| 96 |
#' The pie is drawn slightly inside the node boundary to leave room for arrows. |
|
| 97 |
#' |
|
| 98 |
#' @param x,y Node center coordinates. |
|
| 99 |
#' @param size Node radius. |
|
| 100 |
#' @param values Numeric vector of values (will be normalized to proportions). |
|
| 101 |
#' @param colors Vector of colors for each segment. |
|
| 102 |
#' @param default_color Fallback color when colors is NULL and values length is 1. |
|
| 103 |
#' @param border.col Border color. |
|
| 104 |
#' @param border.width Border line width. |
|
| 105 |
#' @param pie_border.width Border width for pie slice dividers (NULL = use border.width). |
|
| 106 |
#' @keywords internal |
|
| 107 |
draw_pie_node_base <- function(x, y, size, values, colors = NULL, |
|
| 108 |
default_color = NULL, |
|
| 109 |
border.col = "black", border.width = 1, |
|
| 110 |
pie_border.width = NULL) {
|
|
| 111 | 53x |
if (is.null(values) || length(values) == 0) {
|
| 112 | 2x |
return(invisible()) |
| 113 |
} |
|
| 114 | ||
| 115 |
# Draw outer boundary circle first (arrows will touch this) |
|
| 116 | 51x |
angles <- seq(0, 2 * pi, length.out = 100) |
| 117 | 51x |
graphics::polygon( |
| 118 | 51x |
x = x + size * cos(angles), |
| 119 | 51x |
y = y + size * sin(angles), |
| 120 | 51x |
col = "white", |
| 121 | 51x |
border = border.col, |
| 122 | 51x |
lwd = border.width |
| 123 |
) |
|
| 124 | ||
| 125 |
# Pie is drawn inside the boundary |
|
| 126 | 51x |
pie_size <- size * 0.92 |
| 127 | ||
| 128 |
# Normalize to proportions |
|
| 129 | 51x |
props <- values / sum(values) |
| 130 | 51x |
n <- length(props) |
| 131 | ||
| 132 |
# Default colors - use default_color if provided and single segment |
|
| 133 | 51x |
if (is.null(colors)) {
|
| 134 | 30x |
if (!is.null(default_color) && n == 1) {
|
| 135 | 11x |
colors <- default_color |
| 136 |
} else {
|
|
| 137 | 19x |
colors <- grDevices::rainbow(n, s = 0.7, v = 0.9) |
| 138 |
} |
|
| 139 |
} |
|
| 140 | 51x |
colors <- recycle_to_length(colors, n) |
| 141 | ||
| 142 |
# Use separate pie border width if provided |
|
| 143 | 51x |
slice_border_width <- if (!is.null(pie_border.width)) pie_border.width else border.width |
| 144 | ||
| 145 |
# Draw slices |
|
| 146 | 51x |
start_angle <- pi / 2 # Start at top |
| 147 | 51x |
n_points <- 50 |
| 148 | ||
| 149 | 51x |
for (i in seq_len(n)) {
|
| 150 | 5x |
if (props[i] <= 0) next |
| 151 | ||
| 152 | 115x |
end_angle <- start_angle - 2 * pi * props[i] |
| 153 | ||
| 154 |
# Create slice polygon |
|
| 155 | 115x |
angles <- seq(start_angle, end_angle, length.out = max(3, ceiling(n_points * props[i]))) |
| 156 | ||
| 157 | 115x |
xs <- c(x, x + pie_size * cos(angles), x) |
| 158 | 115x |
ys <- c(y, y + pie_size * sin(angles), y) |
| 159 | ||
| 160 | 115x |
graphics::polygon( |
| 161 | 115x |
x = xs, y = ys, |
| 162 | 115x |
col = colors[i], |
| 163 | 115x |
border = NA |
| 164 |
) |
|
| 165 | ||
| 166 | 115x |
start_angle <- end_angle |
| 167 |
} |
|
| 168 | ||
| 169 |
# Draw slice dividers (if more than one slice and border width > 0) |
|
| 170 | 51x |
if (n > 1 && !is.null(slice_border_width) && slice_border_width > 0.1) {
|
| 171 | 40x |
start_angle <- pi / 2 |
| 172 | 40x |
for (i in seq_len(n)) {
|
| 173 | 5x |
if (props[i] <= 0) next |
| 174 | 104x |
end_angle <- start_angle - 2 * pi * props[i] |
| 175 |
# Draw radial line at slice boundary |
|
| 176 | 104x |
graphics::lines( |
| 177 | 104x |
x = c(x, x + pie_size * cos(start_angle)), |
| 178 | 104x |
y = c(y, y + pie_size * sin(start_angle)), |
| 179 | 104x |
col = border.col, |
| 180 | 104x |
lwd = slice_border_width |
| 181 |
) |
|
| 182 | 104x |
start_angle <- end_angle |
| 183 |
} |
|
| 184 |
} |
|
| 185 |
} |
|
| 186 | ||
| 187 |
#' Draw Polygon Donut Node (Base R) |
|
| 188 |
#' |
|
| 189 |
#' Renders a donut on a polygon shape where segments follow polygon edges. |
|
| 190 |
#' The donut shows a fill proportion (0-1) as filled segments starting from the top. |
|
| 191 |
#' |
|
| 192 |
#' @param x,y Node center coordinates. |
|
| 193 |
#' @param size Outer radius. |
|
| 194 |
#' @param values Single numeric value (0-1) specifying fill proportion. |
|
| 195 |
#' 0.1 = 10% filled, 0.5 = 50% filled, 1.0 = full ring. |
|
| 196 |
#' @param colors Fill color for the donut ring. |
|
| 197 |
#' @param default_color Fallback color when colors is NULL. |
|
| 198 |
#' @param inner_ratio Ratio of inner to outer radius (0-1). Default 0.5. |
|
| 199 |
#' @param bg_color Background color for unfilled portion. Default "gray90". |
|
| 200 |
#' @param donut_shape Base polygon shape: "square", "hexagon", "triangle", etc. |
|
| 201 |
#' @param border.col Border color. |
|
| 202 |
#' @param border.width Border line width. |
|
| 203 |
#' @param donut_border.width Border width for donut ring (NULL = use border.width). |
|
| 204 |
#' @param show_value Logical: show value in center? Default FALSE. |
|
| 205 |
#' @param value_cex Text size for center value. |
|
| 206 |
#' @param value_col Text color for center value. |
|
| 207 |
#' @param value_fontface Font face for center value. |
|
| 208 |
#' @param value_fontfamily Font family for center value. |
|
| 209 |
#' @param value_digits Decimal places for value display. |
|
| 210 |
#' @param value_prefix Text before value (e.g., "$"). |
|
| 211 |
#' @param value_suffix Text after value (e.g., "%"). |
|
| 212 |
#' @keywords internal |
|
| 213 |
draw_polygon_donut_node_base <- function(x, y, size, values, colors = NULL, |
|
| 214 |
default_color = NULL, |
|
| 215 |
inner_ratio = 0.5, bg_color = "gray90", |
|
| 216 |
center_color = "white", |
|
| 217 |
donut_shape = "square", |
|
| 218 |
border.col = "black", border.width = 1, |
|
| 219 |
donut_border.width = NULL, |
|
| 220 |
outer_border.col = NULL, |
|
| 221 |
border.lty = 1, |
|
| 222 |
show_value = TRUE, value_cex = 0.8, |
|
| 223 |
value_col = "black", |
|
| 224 |
value_fontface = "bold", value_fontfamily = "sans", |
|
| 225 |
value_digits = 2, value_prefix = "", |
|
| 226 |
value_suffix = "") {
|
|
| 227 | 37x |
ring_border_width <- if (!is.null(donut_border.width)) donut_border.width else border.width |
| 228 | ||
| 229 |
# Get outer polygon vertices |
|
| 230 | 37x |
outer <- get_donut_base_vertices(donut_shape, x, y, size) |
| 231 | ||
| 232 |
# Get inner polygon vertices |
|
| 233 | 37x |
inner <- inset_polygon_vertices(outer, inner_ratio) |
| 234 | ||
| 235 | 37x |
n_verts <- length(outer$x) |
| 236 | 37x |
center_value <- NULL |
| 237 | ||
| 238 |
# Helper to draw a ring segment |
|
| 239 | 37x |
draw_ring_segment <- function(idx_start, idx_end, segment_col) {
|
| 240 | 259x |
seg_x <- c(outer$x[idx_start], outer$x[idx_end], inner$x[idx_end], inner$x[idx_start]) |
| 241 | 259x |
seg_y <- c(outer$y[idx_start], outer$y[idx_end], inner$y[idx_end], inner$y[idx_start]) |
| 242 | 259x |
graphics::polygon(seg_x, seg_y, col = segment_col, border = NA) |
| 243 |
} |
|
| 244 | ||
| 245 | 37x |
if (is.null(values) || length(values) == 0) {
|
| 246 | 1x |
values <- 1 |
| 247 | 1x |
if (is.null(colors)) colors <- if (!is.null(default_color)) default_color else "#4A90D9" |
| 248 |
} |
|
| 249 | ||
| 250 | 37x |
if (length(values) == 1) {
|
| 251 |
# Progress donut |
|
| 252 | 30x |
prop <- max(0, min(1, values)) |
| 253 | 30x |
center_value <- prop |
| 254 | ||
| 255 |
# Draw background ring |
|
| 256 | 30x |
for (i in seq_len(n_verts)) {
|
| 257 | 137x |
i_next <- if (i == n_verts) 1 else i + 1 |
| 258 | 137x |
draw_ring_segment(i, i_next, bg_color) |
| 259 |
} |
|
| 260 | ||
| 261 |
# Draw filled portion |
|
| 262 | 30x |
if (prop > 0) {
|
| 263 | 30x |
segment_col <- if (!is.null(colors)) colors[1] else "maroon" |
| 264 | 30x |
filled_verts <- max(1, round(prop * n_verts)) |
| 265 | ||
| 266 | 30x |
for (i in seq_len(filled_verts)) {
|
| 267 | 80x |
i_next <- if (i == n_verts) 1 else i + 1 |
| 268 | 80x |
draw_ring_segment(i, i_next, segment_col) |
| 269 |
} |
|
| 270 |
} |
|
| 271 |
} else {
|
|
| 272 |
# Multi-segment donut |
|
| 273 | 7x |
props <- values / sum(values) |
| 274 | 7x |
n_seg <- length(props) |
| 275 | ||
| 276 | 7x |
if (is.null(colors)) {
|
| 277 | 1x |
colors <- grDevices::rainbow(n_seg, s = 0.7, v = 0.9) |
| 278 |
} |
|
| 279 | 7x |
colors <- recycle_to_length(colors, n_seg) |
| 280 | ||
| 281 | 7x |
vert_idx <- 1 |
| 282 | 7x |
for (seg in seq_len(n_seg)) {
|
| 283 | 19x |
seg_verts <- max(1, round(props[seg] * n_verts)) |
| 284 | ||
| 285 | 19x |
for (j in seq_len(seg_verts)) {
|
| 286 | 1x |
if (vert_idx > n_verts) break |
| 287 | 42x |
i_next <- if (vert_idx == n_verts) 1 else vert_idx + 1 |
| 288 | 42x |
draw_ring_segment(vert_idx, i_next, colors[seg]) |
| 289 | 42x |
vert_idx <- vert_idx + 1 |
| 290 |
} |
|
| 291 |
} |
|
| 292 |
} |
|
| 293 | ||
| 294 |
# Outer boundary border (double border feature) |
|
| 295 | 37x |
if (!is.null(outer_border.col)) {
|
| 296 |
# Scale up the outer polygon slightly for the double border |
|
| 297 | 4x |
outer_boundary <- list( |
| 298 | 4x |
x = x + (outer$x - x) / 0.92, # Match the 0.92 scaling factor from circular donut |
| 299 | 4x |
y = y + (outer$y - y) / 0.92 |
| 300 |
) |
|
| 301 | 4x |
graphics::polygon(outer_boundary$x, outer_boundary$y, col = NA, |
| 302 | 4x |
border = outer_border.col, lwd = border.width, lty = border.lty) |
| 303 |
} |
|
| 304 | ||
| 305 |
# Outer border |
|
| 306 | 37x |
graphics::polygon(outer$x, outer$y, col = NA, border = border.col, |
| 307 | 37x |
lwd = ring_border_width, lty = border.lty) |
| 308 | ||
| 309 |
# Inner border and fill (center of donut) |
|
| 310 | 37x |
graphics::polygon(inner$x, inner$y, col = center_color, border = border.col, |
| 311 | 37x |
lwd = ring_border_width, lty = border.lty) |
| 312 | ||
| 313 |
# Show value in center |
|
| 314 | 37x |
if (show_value && !is.null(center_value)) {
|
| 315 | 12x |
formatted_value <- round(center_value, value_digits) |
| 316 | 12x |
label_text <- paste0(value_prefix, formatted_value, value_suffix) |
| 317 | ||
| 318 | 12x |
fontface_num <- switch(value_fontface, |
| 319 | 12x |
"plain" = 1, "bold" = 2, "italic" = 3, "bold.italic" = 4, 2 |
| 320 |
) |
|
| 321 | ||
| 322 | 12x |
graphics::text( |
| 323 | 12x |
x = x, y = y, |
| 324 | 12x |
labels = label_text, |
| 325 | 12x |
cex = value_cex, |
| 326 | 12x |
col = value_col, |
| 327 | 12x |
font = fontface_num, |
| 328 | 12x |
family = value_fontfamily |
| 329 |
) |
|
| 330 |
} |
|
| 331 |
} |
|
| 332 | ||
| 333 |
#' Draw Donut Chart Node |
|
| 334 |
#' |
|
| 335 |
#' Renders a node as a donut chart with an inner hole. |
|
| 336 |
#' The donut shows a fill proportion (0-1) as an arc starting from 12 o'clock. |
|
| 337 |
#' |
|
| 338 |
#' @param x,y Node center coordinates. |
|
| 339 |
#' @param size Outer radius. |
|
| 340 |
#' @param values Single numeric value (0-1) specifying fill proportion. |
|
| 341 |
#' 0.1 = 10% filled arc, 0.5 = 50% filled, 1.0 = full ring. |
|
| 342 |
#' @param colors Fill color for the donut ring. |
|
| 343 |
#' @param default_color Fallback color when colors is NULL. |
|
| 344 |
#' @param inner_ratio Ratio of inner to outer radius (0-1). Default 0.5. |
|
| 345 |
#' @param bg_color Background color for unfilled portion. Default "gray90". |
|
| 346 |
#' @param border.col Border color. |
|
| 347 |
#' @param border.width Border line width. |
|
| 348 |
#' @param donut_border.width Border width for donut ring (NULL = use border.width). |
|
| 349 |
#' @param show_value Logical: show value in center? Default FALSE. |
|
| 350 |
#' @param value_cex Text size for center value. |
|
| 351 |
#' @param value_col Text color for center value. |
|
| 352 |
#' @param value_fontface Font face for center value ("plain", "bold", "italic", "bold.italic").
|
|
| 353 |
#' @param value_fontfamily Font family for center value ("sans", "serif", "mono").
|
|
| 354 |
#' @param value_digits Decimal places for value display. |
|
| 355 |
#' @param value_prefix Text before value (e.g., "$"). |
|
| 356 |
#' @param value_suffix Text after value (e.g., "%"). |
|
| 357 |
#' @keywords internal |
|
| 358 |
draw_donut_node_base <- function(x, y, size, values, colors = NULL, |
|
| 359 |
default_color = NULL, |
|
| 360 |
inner_ratio = 0.5, bg_color = "gray90", |
|
| 361 |
center_color = "white", |
|
| 362 |
border.col = "black", border.width = 1, |
|
| 363 |
donut_border.width = NULL, |
|
| 364 |
outer_border.col = NULL, |
|
| 365 |
border.lty = 1, |
|
| 366 |
show_value = TRUE, value_cex = 0.8, |
|
| 367 |
value_col = "black", |
|
| 368 |
value_fontface = "bold", value_fontfamily = "sans", |
|
| 369 |
value_digits = 2, value_prefix = "", |
|
| 370 |
value_suffix = "") {
|
|
| 371 |
# Use separate donut border width if provided |
|
| 372 | 176x |
ring_border_width <- if (!is.null(donut_border.width)) donut_border.width else border.width |
| 373 | ||
| 374 | 176x |
n_points <- 100 |
| 375 | ||
| 376 |
# Draw outer boundary circle first (arrows will touch this) |
|
| 377 | 176x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 378 | 176x |
graphics::polygon( |
| 379 | 176x |
x = x + size * cos(angles), |
| 380 | 176x |
y = y + size * sin(angles), |
| 381 | 176x |
col = "white", |
| 382 | 176x |
border = NA, |
| 383 | 176x |
lwd = border.width |
| 384 |
) |
|
| 385 | ||
| 386 |
# Donut content is drawn inside the boundary |
|
| 387 | 176x |
content_size <- size * 0.92 |
| 388 | 176x |
outer_r <- content_size |
| 389 | 176x |
inner_r <- content_size * inner_ratio |
| 390 | ||
| 391 |
# Helper to draw ring segment |
|
| 392 | 176x |
draw_ring_segment <- function(start_ang, end_ang, outer_r, inner_r, col) {
|
| 393 | 353x |
n_pts <- max(10, ceiling(abs(end_ang - start_ang) / (2 * pi) * n_points)) |
| 394 | 353x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 395 | ||
| 396 |
# Outer arc |
|
| 397 | 353x |
outer_x <- x + outer_r * cos(angles) |
| 398 | 353x |
outer_y <- y + outer_r * sin(angles) |
| 399 | ||
| 400 |
# Inner arc (reversed) |
|
| 401 | 353x |
inner_x <- x + inner_r * cos(rev(angles)) |
| 402 | 353x |
inner_y <- y + inner_r * sin(rev(angles)) |
| 403 | ||
| 404 | 353x |
graphics::polygon( |
| 405 | 353x |
x = c(outer_x, inner_x), |
| 406 | 353x |
y = c(outer_y, inner_y), |
| 407 | 353x |
col = col, |
| 408 | 353x |
border = NA |
| 409 |
) |
|
| 410 |
} |
|
| 411 | ||
| 412 | 176x |
center_value <- NULL |
| 413 | ||
| 414 | 176x |
if (length(values) == 1) {
|
| 415 |
# Single value: progress donut |
|
| 416 | 151x |
prop <- max(0, min(1, values)) |
| 417 | 151x |
center_value <- prop |
| 418 | ||
| 419 |
# Draw background ring |
|
| 420 | 151x |
draw_ring_segment(0, 2 * pi, outer_r, inner_r, bg_color) |
| 421 | ||
| 422 |
# Draw filled portion |
|
| 423 | 151x |
if (prop > 0) {
|
| 424 | 146x |
start_ang <- pi / 2 |
| 425 | 146x |
end_ang <- pi / 2 - 2 * pi * prop |
| 426 | 146x |
fill_col <- if (!is.null(colors)) colors[1] else if (!is.null(default_color)) default_color else "maroon" |
| 427 | 146x |
draw_ring_segment(start_ang, end_ang, outer_r, inner_r, fill_col) |
| 428 |
} |
|
| 429 | ||
| 430 |
} else {
|
|
| 431 |
# Multiple values: segmented donut |
|
| 432 | 25x |
props <- values / sum(values) |
| 433 | 25x |
n <- length(props) |
| 434 | ||
| 435 | 25x |
if (is.null(colors)) {
|
| 436 | 4x |
colors <- grDevices::rainbow(n, s = 0.7, v = 0.9) |
| 437 |
} |
|
| 438 | 25x |
colors <- recycle_to_length(colors, n) |
| 439 | ||
| 440 | 25x |
start_ang <- pi / 2 |
| 441 | 25x |
for (i in seq_len(n)) {
|
| 442 | 4x |
if (props[i] <= 0) next |
| 443 | ||
| 444 | 56x |
end_ang <- start_ang - 2 * pi * props[i] |
| 445 | 56x |
draw_ring_segment(start_ang, end_ang, outer_r, inner_r, colors[i]) |
| 446 | 56x |
start_ang <- end_ang |
| 447 |
} |
|
| 448 |
} |
|
| 449 | ||
| 450 |
# Fill inner hole (center of donut) |
|
| 451 | 176x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 452 | 176x |
graphics::polygon( |
| 453 | 176x |
x = x + inner_r * cos(angles), |
| 454 | 176x |
y = y + inner_r * sin(angles), |
| 455 | 176x |
col = center_color, |
| 456 | 176x |
border = NA |
| 457 |
) |
|
| 458 | ||
| 459 |
# Draw borders |
|
| 460 |
# Outer boundary border (double border feature - at full node size) |
|
| 461 | 176x |
if (!is.null(outer_border.col)) {
|
| 462 | 7x |
graphics::lines( |
| 463 | 7x |
x = x + size * cos(seq(0, 2*pi, length.out = n_points)), |
| 464 | 7x |
y = y + size * sin(seq(0, 2*pi, length.out = n_points)), |
| 465 | 7x |
col = outer_border.col, |
| 466 | 7x |
lwd = border.width, |
| 467 | 7x |
lty = border.lty |
| 468 |
) |
|
| 469 |
} |
|
| 470 |
# Donut ring outer border (at content_size) |
|
| 471 | 176x |
graphics::lines( |
| 472 | 176x |
x = x + outer_r * cos(seq(0, 2*pi, length.out = n_points)), |
| 473 | 176x |
y = y + outer_r * sin(seq(0, 2*pi, length.out = n_points)), |
| 474 | 176x |
col = border.col, |
| 475 | 176x |
lwd = ring_border_width, |
| 476 | 176x |
lty = border.lty |
| 477 |
) |
|
| 478 |
# Donut ring inner border (inner hole) |
|
| 479 | 176x |
graphics::lines( |
| 480 | 176x |
x = x + inner_r * cos(seq(0, 2*pi, length.out = n_points)), |
| 481 | 176x |
y = y + inner_r * sin(seq(0, 2*pi, length.out = n_points)), |
| 482 | 176x |
col = border.col, |
| 483 | 176x |
lwd = ring_border_width, |
| 484 | 176x |
lty = border.lty |
| 485 |
) |
|
| 486 | ||
| 487 |
# Show value in center |
|
| 488 | 176x |
if (show_value && !is.null(center_value)) {
|
| 489 |
# Format the value |
|
| 490 | 28x |
formatted_value <- round(center_value, value_digits) |
| 491 | 28x |
label_text <- paste0(value_prefix, formatted_value, value_suffix) |
| 492 | ||
| 493 |
# Convert fontface string to numeric |
|
| 494 | 28x |
fontface_num <- switch(value_fontface, |
| 495 | 28x |
"plain" = 1, |
| 496 | 28x |
"bold" = 2, |
| 497 | 28x |
"italic" = 3, |
| 498 | 28x |
"bold.italic" = 4, |
| 499 | 28x |
2 # default to bold |
| 500 |
) |
|
| 501 | ||
| 502 | 28x |
graphics::text( |
| 503 | 28x |
x = x, y = y, |
| 504 | 28x |
labels = label_text, |
| 505 | 28x |
cex = value_cex, |
| 506 | 28x |
col = value_col, |
| 507 | 28x |
font = fontface_num, |
| 508 | 28x |
family = value_fontfamily |
| 509 |
) |
|
| 510 |
} |
|
| 511 |
} |
|
| 512 | ||
| 513 |
#' Draw Donut with Inner Pie |
|
| 514 |
#' |
|
| 515 |
#' Renders a node with outer donut ring and inner pie chart. |
|
| 516 |
#' |
|
| 517 |
#' @param x,y Node center coordinates. |
|
| 518 |
#' @param size Outer radius. |
|
| 519 |
#' @param donut_value Single value (0-1) for donut progress. |
|
| 520 |
#' @param donut_color Fill color for donut ring. |
|
| 521 |
#' @param pie_values Numeric vector for pie segments. |
|
| 522 |
#' @param pie_colors Vector of colors for pie segments. |
|
| 523 |
#' @param pie_default_color Default color for pie when pie_colors is NULL. |
|
| 524 |
#' @param inner_ratio Ratio of inner to outer radius. |
|
| 525 |
#' @param bg_color Background color. |
|
| 526 |
#' @param border.col Border color. |
|
| 527 |
#' @param border.width Border line width. |
|
| 528 |
#' @param pie_border.width Border width for pie slice dividers (NULL = use border.width * 0.5). |
|
| 529 |
#' @param donut_border.width Border width for donut ring (NULL = use border.width). |
|
| 530 |
#' @keywords internal |
|
| 531 |
draw_donut_pie_node_base <- function(x, y, size, donut_value = 1, |
|
| 532 |
donut_color = "#4A90D9", |
|
| 533 |
pie_values = NULL, pie_colors = NULL, |
|
| 534 |
pie_default_color = NULL, |
|
| 535 |
inner_ratio = 0.5, bg_color = "gray90", |
|
| 536 |
border.col = "black", border.width = 1, |
|
| 537 |
pie_border.width = NULL, |
|
| 538 |
donut_border.width = NULL) {
|
|
| 539 |
# Use separate border widths if provided |
|
| 540 | 19x |
ring_border_width <- if (!is.null(donut_border.width)) donut_border.width else border.width |
| 541 | 19x |
pie_slice_border <- if (!is.null(pie_border.width)) pie_border.width else border.width * 0.5 |
| 542 | 19x |
n_points <- 100 |
| 543 | ||
| 544 |
# Draw outer boundary circle first (arrows will touch this) |
|
| 545 | 19x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 546 | 19x |
graphics::polygon( |
| 547 | 19x |
x = x + size * cos(angles), |
| 548 | 19x |
y = y + size * sin(angles), |
| 549 | 19x |
col = "white", |
| 550 | 19x |
border = border.col, |
| 551 | 19x |
lwd = border.width |
| 552 |
) |
|
| 553 | ||
| 554 |
# Content is drawn inside the boundary |
|
| 555 | 19x |
content_size <- size * 0.92 |
| 556 | 19x |
outer_r <- content_size |
| 557 | 19x |
inner_r <- content_size * inner_ratio |
| 558 | ||
| 559 |
# Helper to draw ring segment |
|
| 560 | 19x |
draw_ring_segment <- function(start_ang, end_ang, outer_r, inner_r, col) {
|
| 561 | 38x |
n_pts <- max(10, ceiling(abs(end_ang - start_ang) / (2 * pi) * n_points)) |
| 562 | 38x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 563 | ||
| 564 | 38x |
outer_x <- x + outer_r * cos(angles) |
| 565 | 38x |
outer_y <- y + outer_r * sin(angles) |
| 566 | 38x |
inner_x <- x + inner_r * cos(rev(angles)) |
| 567 | 38x |
inner_y <- y + inner_r * sin(rev(angles)) |
| 568 | ||
| 569 | 38x |
graphics::polygon( |
| 570 | 38x |
x = c(outer_x, inner_x), |
| 571 | 38x |
y = c(outer_y, inner_y), |
| 572 | 38x |
col = col, |
| 573 | 38x |
border = NA |
| 574 |
) |
|
| 575 |
} |
|
| 576 | ||
| 577 |
# Draw donut ring background |
|
| 578 | 19x |
draw_ring_segment(0, 2 * pi, outer_r, inner_r, bg_color) |
| 579 | ||
| 580 |
# Draw donut filled portion |
|
| 581 | 19x |
donut_prop <- max(0, min(1, donut_value)) |
| 582 | 19x |
if (donut_prop > 0) {
|
| 583 | 19x |
start_ang <- pi / 2 |
| 584 | 19x |
end_ang <- pi / 2 - 2 * pi * donut_prop |
| 585 | 19x |
draw_ring_segment(start_ang, end_ang, outer_r, inner_r, donut_color) |
| 586 |
} |
|
| 587 | ||
| 588 |
# Draw inner pie |
|
| 589 | 19x |
pie_r <- inner_r * 0.95 |
| 590 | ||
| 591 | 19x |
if (!is.null(pie_values) && length(pie_values) > 0) {
|
| 592 | 18x |
props <- pie_values / sum(pie_values) |
| 593 | 18x |
n <- length(props) |
| 594 | ||
| 595 | 18x |
if (is.null(pie_colors)) {
|
| 596 | 8x |
if (!is.null(pie_default_color) && n == 1) {
|
| 597 | 1x |
pie_colors <- pie_default_color |
| 598 |
} else {
|
|
| 599 | 7x |
pie_colors <- grDevices::rainbow(n, s = 0.7, v = 0.9) |
| 600 |
} |
|
| 601 |
} |
|
| 602 | 18x |
pie_colors <- recycle_to_length(pie_colors, n) |
| 603 | ||
| 604 | 18x |
start_ang <- pi / 2 |
| 605 | 18x |
for (i in seq_len(n)) {
|
| 606 | 3x |
if (props[i] <= 0) next |
| 607 | ||
| 608 | 39x |
end_ang <- start_ang - 2 * pi * props[i] |
| 609 | 39x |
n_pts <- max(3, ceiling(50 * props[i])) |
| 610 | 39x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 611 | ||
| 612 | 39x |
xs <- c(x, x + pie_r * cos(angles), x) |
| 613 | 39x |
ys <- c(y, y + pie_r * sin(angles), y) |
| 614 | ||
| 615 | 39x |
graphics::polygon(x = xs, y = ys, col = pie_colors[i], border = NA) |
| 616 | 39x |
start_ang <- end_ang |
| 617 |
} |
|
| 618 | ||
| 619 |
# Draw pie slice dividers (if more than one slice and border width > 0) |
|
| 620 | 18x |
if (n > 1 && !is.null(pie_slice_border) && pie_slice_border > 0.1) {
|
| 621 | 17x |
start_ang <- pi / 2 |
| 622 | 17x |
for (i in seq_len(n)) {
|
| 623 | 3x |
if (props[i] <= 0) next |
| 624 | 38x |
end_ang <- start_ang - 2 * pi * props[i] |
| 625 | 38x |
graphics::lines( |
| 626 | 38x |
x = c(x, x + pie_r * cos(start_ang)), |
| 627 | 38x |
y = c(y, y + pie_r * sin(start_ang)), |
| 628 | 38x |
col = border.col, |
| 629 | 38x |
lwd = pie_slice_border |
| 630 |
) |
|
| 631 | 38x |
start_ang <- end_ang |
| 632 |
} |
|
| 633 |
} |
|
| 634 |
} else {
|
|
| 635 |
# Fill inner with white |
|
| 636 | 1x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 637 | 1x |
graphics::polygon( |
| 638 | 1x |
x = x + pie_r * cos(angles), |
| 639 | 1x |
y = y + pie_r * sin(angles), |
| 640 | 1x |
col = "white", |
| 641 | 1x |
border = NA |
| 642 |
) |
|
| 643 |
} |
|
| 644 | ||
| 645 |
# Draw borders |
|
| 646 | 19x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 647 | 19x |
graphics::lines(x = x + outer_r * cos(angles), y = y + outer_r * sin(angles), |
| 648 | 19x |
col = border.col, lwd = ring_border_width) |
| 649 | 19x |
graphics::lines(x = x + inner_r * cos(angles), y = y + inner_r * sin(angles), |
| 650 | 19x |
col = border.col, lwd = ring_border_width) |
| 651 |
} |
|
| 652 | ||
| 653 |
#' Draw Double Donut with Inner Pie |
|
| 654 |
#' |
|
| 655 |
#' Renders a node with two concentric donut rings and an optional inner pie chart. |
|
| 656 |
#' From outside to inside: outer donut ring, inner donut ring, center pie. |
|
| 657 |
#' |
|
| 658 |
#' @param x,y Node center coordinates. |
|
| 659 |
#' @param size Outer radius. |
|
| 660 |
#' @param donut_values Values for outer donut ring (vector for segments, or single 0-1 for progress). |
|
| 661 |
#' @param donut_colors Colors for outer donut segments. |
|
| 662 |
#' @param donut2_values Values for inner donut ring (vector for segments, or single 0-1 for progress). |
|
| 663 |
#' @param donut2_colors Colors for inner donut segments. |
|
| 664 |
#' @param pie_values Numeric vector for center pie segments. |
|
| 665 |
#' @param pie_colors Vector of colors for pie segments. |
|
| 666 |
#' @param pie_default_color Default color for pie when pie_colors is NULL. |
|
| 667 |
#' @param outer_inner_ratio Where outer donut ends (inner radius as ratio of outer radius). Default 0.7. |
|
| 668 |
#' @param inner_inner_ratio Where inner donut ends (inner radius as ratio of outer radius). Default 0.4. |
|
| 669 |
#' @param bg_color Background color for unfilled portions. |
|
| 670 |
#' @param border.col Border color. |
|
| 671 |
#' @param border.width Border line width. |
|
| 672 |
#' @param pie_border.width Border width for pie slice dividers. |
|
| 673 |
#' @param donut_border.width Border width for donut rings. |
|
| 674 |
#' @keywords internal |
|
| 675 |
draw_double_donut_pie_node_base <- function(x, y, size, |
|
| 676 |
donut_values = NULL, donut_colors = NULL, |
|
| 677 |
donut2_values = NULL, donut2_colors = NULL, |
|
| 678 |
pie_values = NULL, pie_colors = NULL, |
|
| 679 |
pie_default_color = NULL, |
|
| 680 |
outer_inner_ratio = 0.7, |
|
| 681 |
inner_inner_ratio = 0.4, |
|
| 682 |
bg_color = "gray90", |
|
| 683 |
border.col = "black", border.width = 1, |
|
| 684 |
pie_border.width = NULL, |
|
| 685 |
donut_border.width = NULL) {
|
|
| 686 |
# Use separate border widths if provided |
|
| 687 | 21x |
ring_border_width <- if (!is.null(donut_border.width)) donut_border.width else border.width |
| 688 | 21x |
pie_slice_border <- if (!is.null(pie_border.width)) pie_border.width else border.width * 0.5 |
| 689 | 21x |
n_points <- 100 |
| 690 | ||
| 691 |
# Draw outer boundary circle first (arrows will touch this) |
|
| 692 | 21x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 693 | 21x |
graphics::polygon( |
| 694 | 21x |
x = x + size * cos(angles), |
| 695 | 21x |
y = y + size * sin(angles), |
| 696 | 21x |
col = "white", |
| 697 | 21x |
border = border.col, |
| 698 | 21x |
lwd = border.width |
| 699 |
) |
|
| 700 | ||
| 701 |
# Content is drawn inside the boundary |
|
| 702 | 21x |
content_size <- size * 0.92 |
| 703 | ||
| 704 |
# Define radii for the three layers (scaled down) |
|
| 705 | 21x |
outer_r <- content_size # Outermost edge of content |
| 706 | 21x |
mid_r <- content_size * outer_inner_ratio # Between outer and inner donut |
| 707 | 21x |
inner_r <- content_size * inner_inner_ratio # Inner edge of inner donut / outer edge of pie |
| 708 | ||
| 709 |
# Helper to draw ring segment |
|
| 710 | 21x |
draw_ring_segment <- function(start_ang, end_ang, r_outer, r_inner, col) {
|
| 711 | 83x |
n_pts <- max(10, ceiling(abs(end_ang - start_ang) / (2 * pi) * n_points)) |
| 712 | 83x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 713 | ||
| 714 | 83x |
outer_x <- x + r_outer * cos(angles) |
| 715 | 83x |
outer_y <- y + r_outer * sin(angles) |
| 716 | 83x |
inner_x <- x + r_inner * cos(rev(angles)) |
| 717 | 83x |
inner_y <- y + r_inner * sin(rev(angles)) |
| 718 | ||
| 719 | 83x |
graphics::polygon( |
| 720 | 83x |
x = c(outer_x, inner_x), |
| 721 | 83x |
y = c(outer_y, inner_y), |
| 722 | 83x |
col = col, |
| 723 | 83x |
border = NA |
| 724 |
) |
|
| 725 |
} |
|
| 726 | ||
| 727 |
# Helper to draw donut ring (handles both progress and segmented) |
|
| 728 | 21x |
draw_donut_ring <- function(values, colors, default_color, r_outer, r_inner) {
|
| 729 | ! |
if (is.null(values)) return() |
| 730 | ||
| 731 | 40x |
if (length(values) == 1) {
|
| 732 |
# Progress donut - draw background then filled portion |
|
| 733 | 29x |
draw_ring_segment(0, 2 * pi, r_outer, r_inner, bg_color) |
| 734 | 29x |
prop <- max(0, min(1, values)) |
| 735 | 29x |
if (prop > 0) {
|
| 736 | 29x |
fill_col <- if (!is.null(colors)) colors[1] else if (!is.null(default_color)) default_color else "#4A90D9" |
| 737 | 29x |
start_ang <- pi / 2 |
| 738 | 29x |
end_ang <- pi / 2 - 2 * pi * prop |
| 739 | 29x |
draw_ring_segment(start_ang, end_ang, r_outer, r_inner, fill_col) |
| 740 |
} |
|
| 741 |
} else {
|
|
| 742 |
# Segmented donut |
|
| 743 | 11x |
props <- values / sum(values) |
| 744 | 11x |
n <- length(props) |
| 745 | ||
| 746 | 11x |
if (is.null(colors)) {
|
| 747 | 6x |
colors <- grDevices::rainbow(n, s = 0.7, v = 0.9) |
| 748 |
} |
|
| 749 | 11x |
colors <- recycle_to_length(colors, n) |
| 750 | ||
| 751 | 11x |
start_ang <- pi / 2 |
| 752 | 11x |
for (i in seq_len(n)) {
|
| 753 | 3x |
if (props[i] <= 0) next |
| 754 | 23x |
end_ang <- start_ang - 2 * pi * props[i] |
| 755 | 23x |
draw_ring_segment(start_ang, end_ang, r_outer, r_inner, colors[i]) |
| 756 | 23x |
start_ang <- end_ang |
| 757 |
} |
|
| 758 |
} |
|
| 759 |
} |
|
| 760 | ||
| 761 |
# 1. Draw outer donut ring (if values provided) |
|
| 762 | 21x |
if (!is.null(donut_values)) {
|
| 763 | 20x |
draw_donut_ring(donut_values, donut_colors, NULL, outer_r, mid_r) |
| 764 |
} else {
|
|
| 765 |
# Fill with background if no outer donut |
|
| 766 | 1x |
draw_ring_segment(0, 2 * pi, outer_r, mid_r, bg_color) |
| 767 |
} |
|
| 768 | ||
| 769 |
# 2. Draw inner donut ring (if values provided) |
|
| 770 | 21x |
if (!is.null(donut2_values)) {
|
| 771 | 20x |
draw_donut_ring(donut2_values, donut2_colors, NULL, mid_r, inner_r) |
| 772 |
} else {
|
|
| 773 |
# Fill with background if no inner donut |
|
| 774 | 1x |
draw_ring_segment(0, 2 * pi, mid_r, inner_r, bg_color) |
| 775 |
} |
|
| 776 | ||
| 777 |
# 3. Draw center pie (if values provided) |
|
| 778 | 21x |
pie_r <- inner_r * 0.95 |
| 779 | 21x |
if (!is.null(pie_values) && length(pie_values) > 0) {
|
| 780 | 12x |
props <- pie_values / sum(pie_values) |
| 781 | 12x |
n <- length(props) |
| 782 | ||
| 783 | 12x |
if (is.null(pie_colors)) {
|
| 784 | 4x |
if (!is.null(pie_default_color) && n == 1) {
|
| 785 | 1x |
pie_colors <- pie_default_color |
| 786 |
} else {
|
|
| 787 | 3x |
pie_colors <- grDevices::rainbow(n, s = 0.7, v = 0.9) |
| 788 |
} |
|
| 789 |
} |
|
| 790 | 12x |
pie_colors <- recycle_to_length(pie_colors, n) |
| 791 | ||
| 792 | 12x |
start_ang <- pi / 2 |
| 793 | 12x |
for (i in seq_len(n)) {
|
| 794 | 4x |
if (props[i] <= 0) next |
| 795 | ||
| 796 | 24x |
end_ang <- start_ang - 2 * pi * props[i] |
| 797 | 24x |
n_pts <- max(3, ceiling(50 * props[i])) |
| 798 | 24x |
angles <- seq(start_ang, end_ang, length.out = n_pts) |
| 799 | ||
| 800 | 24x |
xs <- c(x, x + pie_r * cos(angles), x) |
| 801 | 24x |
ys <- c(y, y + pie_r * sin(angles), y) |
| 802 | ||
| 803 | 24x |
graphics::polygon(x = xs, y = ys, col = pie_colors[i], border = NA) |
| 804 | 24x |
start_ang <- end_ang |
| 805 |
} |
|
| 806 | ||
| 807 |
# Draw pie slice dividers (if more than one slice and border width > 0) |
|
| 808 | 12x |
if (n > 1 && !is.null(pie_slice_border) && pie_slice_border > 0.1) {
|
| 809 | 11x |
start_ang <- pi / 2 |
| 810 | 11x |
for (i in seq_len(n)) {
|
| 811 | 4x |
if (props[i] <= 0) next |
| 812 | 23x |
end_ang <- start_ang - 2 * pi * props[i] |
| 813 | 23x |
graphics::lines( |
| 814 | 23x |
x = c(x, x + pie_r * cos(start_ang)), |
| 815 | 23x |
y = c(y, y + pie_r * sin(start_ang)), |
| 816 | 23x |
col = border.col, |
| 817 | 23x |
lwd = pie_slice_border |
| 818 |
) |
|
| 819 | 23x |
start_ang <- end_ang |
| 820 |
} |
|
| 821 |
} |
|
| 822 |
} else {
|
|
| 823 |
# Fill center with white |
|
| 824 | 9x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 825 | 9x |
graphics::polygon( |
| 826 | 9x |
x = x + pie_r * cos(angles), |
| 827 | 9x |
y = y + pie_r * sin(angles), |
| 828 | 9x |
col = "white", |
| 829 | 9x |
border = NA |
| 830 |
) |
|
| 831 |
} |
|
| 832 | ||
| 833 |
# 4. Draw all borders |
|
| 834 | 21x |
angles <- seq(0, 2 * pi, length.out = n_points) |
| 835 |
# Outer border |
|
| 836 | 21x |
graphics::lines(x = x + outer_r * cos(angles), y = y + outer_r * sin(angles), |
| 837 | 21x |
col = border.col, lwd = ring_border_width) |
| 838 |
# Middle border (between outer and inner donut) |
|
| 839 | 21x |
graphics::lines(x = x + mid_r * cos(angles), y = y + mid_r * sin(angles), |
| 840 | 21x |
col = border.col, lwd = ring_border_width) |
| 841 |
# Inner border (between inner donut and pie) |
|
| 842 | 21x |
graphics::lines(x = x + inner_r * cos(angles), y = y + inner_r * sin(angles), |
| 843 | 21x |
col = border.col, lwd = ring_border_width) |
| 844 |
} |
|
| 845 | ||
| 846 |
#' Draw Node Label |
|
| 847 |
#' |
|
| 848 |
#' Renders a text label at or near a node. |
|
| 849 |
#' |
|
| 850 |
#' @param x,y Label position coordinates. |
|
| 851 |
#' @param label Text to display. |
|
| 852 |
#' @param cex Character expansion factor. |
|
| 853 |
#' @param col Text color. |
|
| 854 |
#' @param font Font face (1=plain, 2=bold, 3=italic, 4=bold italic). |
|
| 855 |
#' @param family Font family ("sans", "serif", "mono").
|
|
| 856 |
#' @param hjust Horizontal justification (0=left, 0.5=center, 1=right). |
|
| 857 |
#' @param vjust Vertical justification (0=bottom, 0.5=center, 1=top). |
|
| 858 |
#' @param srt String rotation angle in degrees. |
|
| 859 |
#' @param pos Position relative to point (NULL=centered, 1=below, 2=left, 3=above, 4=right). |
|
| 860 |
#' @param offset Offset distance when using pos. |
|
| 861 |
#' @keywords internal |
|
| 862 |
draw_node_label_base <- function(x, y, label, cex = 1, col = "black", |
|
| 863 |
font = 1, family = "sans", |
|
| 864 |
hjust = 0.5, vjust = 0.5, srt = 0, |
|
| 865 |
pos = NULL, offset = 0.5) {
|
|
| 866 | 2662x |
if (is.null(label) || is.na(label) || label == "") {
|
| 867 | 3x |
return(invisible()) |
| 868 |
} |
|
| 869 | ||
| 870 |
# Convert hjust/vjust to adj parameter |
|
| 871 | 2659x |
adj <- c(hjust, vjust) |
| 872 | ||
| 873 | 2659x |
graphics::text( |
| 874 | 2659x |
x = x, y = y, |
| 875 | 2659x |
labels = label, |
| 876 | 2659x |
cex = cex, |
| 877 | 2659x |
col = col, |
| 878 | 2659x |
font = font, |
| 879 | 2659x |
family = family, |
| 880 | 2659x |
adj = adj, |
| 881 | 2659x |
srt = srt, |
| 882 | 2659x |
pos = pos, |
| 883 | 2659x |
offset = offset |
| 884 |
) |
|
| 885 |
} |
|
| 886 | ||
| 887 |
#' Draw Neural Node (Base R) |
|
| 888 |
#' |
|
| 889 |
#' Circle with small connection circles around perimeter. |
|
| 890 |
#' |
|
| 891 |
#' @keywords internal |
|
| 892 |
draw_neural_node_base <- function(x, y, size, col, border.col, border.width, |
|
| 893 |
n_connections = 6) {
|
|
| 894 |
# Main center circle |
|
| 895 | 6x |
graphics::symbols( |
| 896 | 6x |
x = x, y = y, |
| 897 | 6x |
circles = size * 0.6, |
| 898 | 6x |
inches = FALSE, add = TRUE, |
| 899 | 6x |
fg = border.col, bg = col, lwd = border.width |
| 900 |
) |
|
| 901 | ||
| 902 |
# Connection circles around perimeter |
|
| 903 | 6x |
conn_radius <- size * 0.15 |
| 904 | 6x |
angles <- seq(0, 2 * pi * (1 - 1/n_connections), length.out = n_connections) |
| 905 | ||
| 906 | 6x |
for (i in seq_along(angles)) {
|
| 907 | 36x |
cx <- x + size * 0.85 * cos(angles[i]) |
| 908 | 36x |
cy <- y + size * 0.85 * sin(angles[i]) |
| 909 | ||
| 910 |
# Line from center to connection |
|
| 911 | 36x |
graphics::lines(c(x, cx), c(y, cy), col = border.col, lwd = border.width * 0.5) |
| 912 | ||
| 913 |
# Connection circle |
|
| 914 | 36x |
graphics::symbols( |
| 915 | 36x |
x = cx, y = cy, |
| 916 | 36x |
circles = conn_radius, |
| 917 | 36x |
inches = FALSE, add = TRUE, |
| 918 | 36x |
fg = border.col, bg = col, lwd = border.width * 0.7 |
| 919 |
) |
|
| 920 |
} |
|
| 921 |
} |
|
| 922 | ||
| 923 |
#' Draw Chip Node (Base R) |
|
| 924 |
#' |
|
| 925 |
#' Square with pins extending from all edges. |
|
| 926 |
#' |
|
| 927 |
#' @keywords internal |
|
| 928 |
draw_chip_node_base <- function(x, y, size, col, border.col, border.width, |
|
| 929 |
pins_per_side = 3) {
|
|
| 930 | 6x |
body_size <- size * 0.7 |
| 931 | 6x |
pin_length <- size * 0.2 |
| 932 | 6x |
pin_width <- body_size * 0.8 / (pins_per_side * 2 - 1) |
| 933 | ||
| 934 |
# Main body (square with corner notch) |
|
| 935 | 6x |
notch_size <- body_size * 0.15 |
| 936 | 6x |
xs <- c(x - body_size, x - body_size + notch_size, x + body_size, x + body_size, x - body_size) |
| 937 | 6x |
ys <- c(y - body_size, y + body_size, y + body_size, y - body_size, y - body_size) |
| 938 | 6x |
graphics::polygon(xs, ys, col = col, border = border.col, lwd = border.width) |
| 939 | ||
| 940 |
# Draw pins |
|
| 941 | 6x |
for (side in c("top", "bottom", "left", "right")) {
|
| 942 | 24x |
for (i in seq_len(pins_per_side)) {
|
| 943 | 72x |
offset <- (i - (pins_per_side + 1) / 2) * (body_size * 1.5 / pins_per_side) |
| 944 | ||
| 945 | 72x |
if (side == "top") {
|
| 946 | 18x |
px <- x + offset |
| 947 | 18x |
py <- y + body_size |
| 948 | 18x |
p_xs <- c(px - pin_width/2, px + pin_width/2, px + pin_width/2, px - pin_width/2) |
| 949 | 18x |
p_ys <- c(py, py, py + pin_length, py + pin_length) |
| 950 | 54x |
} else if (side == "bottom") {
|
| 951 | 18x |
px <- x + offset |
| 952 | 18x |
py <- y - body_size |
| 953 | 18x |
p_xs <- c(px - pin_width/2, px + pin_width/2, px + pin_width/2, px - pin_width/2) |
| 954 | 18x |
p_ys <- c(py, py, py - pin_length, py - pin_length) |
| 955 | 36x |
} else if (side == "left") {
|
| 956 | 18x |
px <- x - body_size |
| 957 | 18x |
py <- y + offset |
| 958 | 18x |
p_xs <- c(px, px, px - pin_length, px - pin_length) |
| 959 | 18x |
p_ys <- c(py - pin_width/2, py + pin_width/2, py + pin_width/2, py - pin_width/2) |
| 960 |
} else {
|
|
| 961 | 18x |
px <- x + body_size |
| 962 | 18x |
py <- y + offset |
| 963 | 18x |
p_xs <- c(px, px, px + pin_length, px + pin_length) |
| 964 | 18x |
p_ys <- c(py - pin_width/2, py + pin_width/2, py + pin_width/2, py - pin_width/2) |
| 965 |
} |
|
| 966 | ||
| 967 | 72x |
graphics::polygon(p_xs, p_ys, col = border.col, border = border.col) |
| 968 |
} |
|
| 969 |
} |
|
| 970 |
} |
|
| 971 | ||
| 972 |
#' Draw Robot Node (Base R) |
|
| 973 |
#' |
|
| 974 |
#' Rounded square with antenna and eyes. |
|
| 975 |
#' |
|
| 976 |
#' @keywords internal |
|
| 977 |
draw_robot_node_base <- function(x, y, size, col, border.col, border.width) {
|
|
| 978 | 6x |
head_w <- size * 0.8 |
| 979 | 6x |
head_h <- size * 0.7 |
| 980 | ||
| 981 |
# Robot head (rectangle with rounded-ish appearance) |
|
| 982 | 6x |
graphics::rect( |
| 983 | 6x |
xleft = x - head_w, ybottom = y - head_h - size * 0.1, |
| 984 | 6x |
xright = x + head_w, ytop = y + head_h - size * 0.1, |
| 985 | 6x |
col = col, border = border.col, lwd = border.width |
| 986 |
) |
|
| 987 | ||
| 988 |
# Antenna |
|
| 989 | 6x |
antenna_base_y <- y + head_h - size * 0.1 |
| 990 | 6x |
graphics::lines(c(x, x), c(antenna_base_y, y + size), col = border.col, lwd = border.width) |
| 991 | 6x |
graphics::symbols( |
| 992 | 6x |
x = x, y = y + size + size * 0.08, |
| 993 | 6x |
circles = size * 0.08, |
| 994 | 6x |
inches = FALSE, add = TRUE, fg = border.col, bg = border.col |
| 995 |
) |
|
| 996 | ||
| 997 |
# Eyes |
|
| 998 | 6x |
eye_y <- y |
| 999 | 6x |
eye_radius <- size * 0.12 |
| 1000 | 6x |
graphics::symbols( |
| 1001 | 6x |
x = c(x - head_w * 0.4, x + head_w * 0.4), |
| 1002 | 6x |
y = c(eye_y, eye_y), |
| 1003 | 6x |
circles = rep(eye_radius, 2), |
| 1004 | 6x |
inches = FALSE, add = TRUE, |
| 1005 | 6x |
fg = border.col, bg = "white", lwd = border.width * 0.7 |
| 1006 |
) |
|
| 1007 | ||
| 1008 |
# Mouth |
|
| 1009 | 6x |
graphics::lines( |
| 1010 | 6x |
c(x - head_w * 0.3, x + head_w * 0.3), |
| 1011 | 6x |
c(y - head_h * 0.4, y - head_h * 0.4), |
| 1012 | 6x |
col = border.col, lwd = border.width |
| 1013 |
) |
|
| 1014 |
} |
|
| 1015 | ||
| 1016 |
#' Draw Network Node (Base R) |
|
| 1017 |
#' |
|
| 1018 |
#' Interconnected nodes pattern. |
|
| 1019 |
#' |
|
| 1020 |
#' @keywords internal |
|
| 1021 |
draw_network_node_base <- function(x, y, size, col, border.col, border.width) {
|
|
| 1022 |
# Outer boundary |
|
| 1023 | 6x |
graphics::symbols( |
| 1024 | 6x |
x = x, y = y, |
| 1025 | 6x |
circles = size, |
| 1026 | 6x |
inches = FALSE, add = TRUE, |
| 1027 | 6x |
fg = border.col, bg = col, lwd = border.width |
| 1028 |
) |
|
| 1029 | ||
| 1030 |
# Mini nodes (pentagon arrangement) |
|
| 1031 | 6x |
n_nodes <- 5 |
| 1032 | 6x |
inner_r <- size * 0.55 |
| 1033 | 6x |
node_r <- size * 0.12 |
| 1034 | 6x |
angles <- seq(pi/2, pi/2 + 2 * pi * (1 - 1/n_nodes), length.out = n_nodes) |
| 1035 | ||
| 1036 | 6x |
node_x <- x + inner_r * cos(angles) |
| 1037 | 6x |
node_y <- y + inner_r * sin(angles) |
| 1038 | ||
| 1039 |
# Edges |
|
| 1040 | 6x |
for (i in seq_len(n_nodes)) {
|
| 1041 | 30x |
for (j in seq_len(n_nodes)) {
|
| 1042 | 150x |
if (i < j) {
|
| 1043 | 60x |
graphics::lines( |
| 1044 | 60x |
c(node_x[i], node_x[j]), c(node_y[i], node_y[j]), |
| 1045 | 60x |
col = border.col, lwd = border.width * 0.5 |
| 1046 |
) |
|
| 1047 |
} |
|
| 1048 |
} |
|
| 1049 |
} |
|
| 1050 | ||
| 1051 |
# Nodes |
|
| 1052 | 6x |
graphics::symbols( |
| 1053 | 6x |
x = node_x, y = node_y, |
| 1054 | 6x |
circles = rep(node_r, n_nodes), |
| 1055 | 6x |
inches = FALSE, add = TRUE, |
| 1056 | 6x |
fg = border.col, bg = "white", lwd = border.width * 0.7 |
| 1057 |
) |
|
| 1058 |
} |
|
| 1059 | ||
| 1060 |
#' Draw Database Node (Base R) |
|
| 1061 |
#' |
|
| 1062 |
#' Cylinder shape. |
|
| 1063 |
#' |
|
| 1064 |
#' @keywords internal |
|
| 1065 |
draw_database_node_base <- function(x, y, size, col, border.col, border.width) {
|
|
| 1066 | 6x |
cyl_width <- size * 0.8 |
| 1067 | 6x |
cyl_height <- size * 1.2 |
| 1068 | 6x |
ellipse_h <- size * 0.25 |
| 1069 | ||
| 1070 | 6x |
n_pts <- 50 |
| 1071 | 6x |
bottom_y <- y - cyl_height / 2 |
| 1072 | 6x |
top_y <- y + cyl_height / 2 |
| 1073 | ||
| 1074 |
# Body |
|
| 1075 | 6x |
graphics::rect( |
| 1076 | 6x |
xleft = x - cyl_width, ybottom = bottom_y, |
| 1077 | 6x |
xright = x + cyl_width, ytop = top_y, |
| 1078 | 6x |
col = col, border = NA |
| 1079 |
) |
|
| 1080 | ||
| 1081 |
# Side lines |
|
| 1082 | 6x |
graphics::lines(c(x - cyl_width, x - cyl_width), c(bottom_y, top_y), col = border.col, lwd = border.width) |
| 1083 | 6x |
graphics::lines(c(x + cyl_width, x + cyl_width), c(bottom_y, top_y), col = border.col, lwd = border.width) |
| 1084 | ||
| 1085 |
# Bottom ellipse (lower arc) |
|
| 1086 | 6x |
angles <- seq(0, pi, length.out = n_pts) |
| 1087 | 6x |
bottom_x <- x + cyl_width * cos(angles) |
| 1088 | 6x |
bottom_y_pts <- bottom_y + ellipse_h * sin(angles) * (-1) |
| 1089 | 6x |
graphics::lines(bottom_x, bottom_y_pts, col = border.col, lwd = border.width) |
| 1090 | ||
| 1091 |
# Top ellipse |
|
| 1092 | 6x |
angles_full <- seq(0, 2 * pi, length.out = n_pts * 2) |
| 1093 | 6x |
top_x <- x + cyl_width * cos(angles_full) |
| 1094 | 6x |
top_y_pts <- top_y + ellipse_h * sin(angles_full) |
| 1095 | 6x |
graphics::polygon(top_x, top_y_pts, col = col, border = border.col, lwd = border.width) |
| 1096 |
} |
|
| 1097 | ||
| 1098 |
#' Render All Nodes |
|
| 1099 |
#' |
|
| 1100 |
#' Renders all nodes in the network. |
|
| 1101 |
#' |
|
| 1102 |
#' @param layout Matrix with x, y columns. |
|
| 1103 |
#' @param vsize Vector of node sizes. |
|
| 1104 |
#' @param vsize2 Vector of secondary sizes (for ellipse). |
|
| 1105 |
#' @param shape Vector of shape names. |
|
| 1106 |
#' @param color Vector of fill colors. |
|
| 1107 |
#' @param border.color Vector of border colors. |
|
| 1108 |
#' @param border.width Vector of border widths. |
|
| 1109 |
#' @param pie List of pie value vectors (one per node) or NULL. |
|
| 1110 |
#' @param pieColor List of pie color vectors or NULL. |
|
| 1111 |
#' @param donut List of donut values or NULL. |
|
| 1112 |
#' @param donutColor List of donut color vectors or NULL. |
|
| 1113 |
#' @param labels Vector of labels or NULL. |
|
| 1114 |
#' @param label.cex Vector of label sizes. |
|
| 1115 |
#' @param label.color Vector of label colors. |
|
| 1116 |
#' @keywords internal |
|
| 1117 |
render_nodes_base <- function(layout, vsize, vsize2 = NULL, shape = "circle", |
|
| 1118 |
color = "#4A90D9", border.color = "#2C5AA0", |
|
| 1119 |
border.width = 1, pie = NULL, pieColor = NULL, |
|
| 1120 |
donut = NULL, donutColor = NULL, |
|
| 1121 |
labels = NULL, label.cex = 1, label.color = "black") {
|
|
| 1122 | 3x |
n <- nrow(layout) |
| 1123 | 1x |
if (n == 0) return(invisible()) |
| 1124 | ||
| 1125 |
# Vectorize all parameters |
|
| 1126 | 2x |
vsize <- recycle_to_length(vsize, n) |
| 1127 | 2x |
vsize2 <- if (!is.null(vsize2)) recycle_to_length(vsize2, n) else vsize |
| 1128 | 2x |
shape <- recycle_to_length(shape, n) |
| 1129 | 2x |
color <- recycle_to_length(color, n) |
| 1130 | 2x |
border.color <- recycle_to_length(border.color, n) |
| 1131 | 2x |
border.width <- recycle_to_length(border.width, n) |
| 1132 | 2x |
label.cex <- recycle_to_length(label.cex, n) |
| 1133 | 2x |
label.color <- recycle_to_length(label.color, n) |
| 1134 | ||
| 1135 |
# Render order: largest to smallest |
|
| 1136 | 2x |
order_idx <- get_node_order(vsize) |
| 1137 | ||
| 1138 | 2x |
for (i in order_idx) {
|
| 1139 | 6x |
x <- layout[i, 1] |
| 1140 | 6x |
y <- layout[i, 2] |
| 1141 | ||
| 1142 |
# Check for pie/donut |
|
| 1143 | 6x |
has_pie <- !is.null(pie) && length(pie) >= i && !is.null(pie[[i]]) && length(pie[[i]]) > 0 |
| 1144 | 6x |
has_donut <- !is.null(donut) && length(donut) >= i && !is.null(donut[[i]]) |
| 1145 | ||
| 1146 | 6x |
if (has_donut && has_pie) {
|
| 1147 |
# Donut with inner pie |
|
| 1148 | 1x |
donut_val <- if (length(donut[[i]]) == 1) donut[[i]] else 1 |
| 1149 | 1x |
donut_col <- if (!is.null(donutColor) && length(donutColor) >= i) donutColor[[i]][1] else color[i] |
| 1150 | 1x |
pie_vals <- pie[[i]] |
| 1151 | 1x |
pie_cols <- if (!is.null(pieColor) && length(pieColor) >= i) pieColor[[i]] else NULL |
| 1152 | ||
| 1153 | 1x |
draw_donut_pie_node_base( |
| 1154 | 1x |
x, y, vsize[i], |
| 1155 | 1x |
donut_value = donut_val, |
| 1156 | 1x |
donut_color = donut_col, |
| 1157 | 1x |
pie_values = pie_vals, |
| 1158 | 1x |
pie_colors = pie_cols, |
| 1159 | 1x |
border.col = border.color[i], |
| 1160 | 1x |
border.width = border.width[i] |
| 1161 |
) |
|
| 1162 | ||
| 1163 | 5x |
} else if (has_donut) {
|
| 1164 |
# Donut only |
|
| 1165 | 1x |
donut_vals <- donut[[i]] |
| 1166 | 1x |
donut_cols <- if (!is.null(donutColor) && length(donutColor) >= i) donutColor[[i]] else color[i] |
| 1167 | ||
| 1168 | 1x |
draw_donut_node_base( |
| 1169 | 1x |
x, y, vsize[i], |
| 1170 | 1x |
values = donut_vals, |
| 1171 | 1x |
colors = donut_cols, |
| 1172 | 1x |
border.col = border.color[i], |
| 1173 | 1x |
border.width = border.width[i] |
| 1174 |
) |
|
| 1175 | ||
| 1176 | 4x |
} else if (has_pie) {
|
| 1177 |
# Pie only |
|
| 1178 | 1x |
pie_vals <- pie[[i]] |
| 1179 | 1x |
pie_cols <- if (!is.null(pieColor) && length(pieColor) >= i) pieColor[[i]] else NULL |
| 1180 | ||
| 1181 | 1x |
draw_pie_node_base( |
| 1182 | 1x |
x, y, vsize[i], |
| 1183 | 1x |
values = pie_vals, |
| 1184 | 1x |
colors = pie_cols, |
| 1185 | 1x |
border.col = border.color[i], |
| 1186 | 1x |
border.width = border.width[i] |
| 1187 |
) |
|
| 1188 | ||
| 1189 |
} else {
|
|
| 1190 |
# Standard node |
|
| 1191 | 3x |
draw_node_base( |
| 1192 | 3x |
x, y, vsize[i], vsize2[i], |
| 1193 | 3x |
shape = shape[i], |
| 1194 | 3x |
col = color[i], |
| 1195 | 3x |
border.col = border.color[i], |
| 1196 | 3x |
border.width = border.width[i] |
| 1197 |
) |
|
| 1198 |
} |
|
| 1199 |
} |
|
| 1200 | ||
| 1201 |
# Render labels (all at once, on top of nodes) |
|
| 1202 | 2x |
if (!is.null(labels)) {
|
| 1203 | 2x |
for (i in seq_len(n)) {
|
| 1204 | 6x |
if (!is.null(labels[i]) && !is.na(labels[i]) && labels[i] != "") {
|
| 1205 | 5x |
draw_node_label_base( |
| 1206 | 5x |
layout[i, 1], layout[i, 2], |
| 1207 | 5x |
label = labels[i], |
| 1208 | 5x |
cex = label.cex[i], |
| 1209 | 5x |
col = label.color[i] |
| 1210 |
) |
|
| 1211 |
} |
|
| 1212 |
} |
|
| 1213 |
} |
|
| 1214 |
} |
| 1 |
#' Multi-Cluster TNA Network Plot |
|
| 2 |
#' |
|
| 3 |
#' Visualizes multiple network clusters with summary edges between clusters |
|
| 4 |
#' and individual edges within clusters. Each cluster is displayed as a |
|
| 5 |
#' shape (circle, square, diamond, triangle) containing its nodes. |
|
| 6 |
#' |
|
| 7 |
#' @param x A tna object or weight matrix. |
|
| 8 |
#' @param cluster_list List of character vectors defining clusters. |
|
| 9 |
#' Each cluster becomes a separate shape in the layout. |
|
| 10 |
#' @param layout How to arrange the clusters: "circle" (default), |
|
| 11 |
#' "grid", "horizontal", "vertical". |
|
| 12 |
#' @param spacing Distance between cluster centers. Default 3. |
|
| 13 |
#' @param shape_size Size of each cluster shape (shell radius). Default 1.2. |
|
| 14 |
#' @param node_spacing Radius for node placement within shapes (0-1 relative |
|
| 15 |
#' to shape_size). Default 0.5. |
|
| 16 |
#' @param colors Vector of colors for each cluster. Default auto-generated. |
|
| 17 |
#' @param shapes Vector of shapes for each cluster: "circle", "square", |
|
| 18 |
#' "diamond", "triangle". Default cycles through these. |
|
| 19 |
#' @param edge_colors Vector of edge colors by source cluster. Default auto-generated. |
|
| 20 |
#' @param bundle_edges Logical. Bundle inter-cluster edges through channels. Default TRUE. |
|
| 21 |
#' @param bundle_strength How tightly to bundle edges (0-1). Default 0.8. |
|
| 22 |
#' @param summary_edges Logical. Show aggregated summary edges between clusters instead |
|
| 23 |
#' of individual node edges. Default TRUE. |
|
| 24 |
#' @param within_edges Logical. When summary_edges is TRUE, also show individual |
|
| 25 |
#' edges within each cluster. Default TRUE. |
|
| 26 |
#' @param show_border Logical. Draw a border around each cluster. Default TRUE. |
|
| 27 |
#' @param legend Logical. Whether to show legend. Default TRUE. |
|
| 28 |
#' @param legend_position Position for legend. Default "topright". |
|
| 29 |
#' @param curvature Edge curvature. Default 0.3. |
|
| 30 |
#' @param node_size Size of nodes inside shapes. Default 2. |
|
| 31 |
#' @param ... Additional parameters passed to plot_tna(). |
|
| 32 |
#' |
|
| 33 |
#' @return Invisibly returns NULL for summary mode, or the plot_tna result. |
|
| 34 |
#' |
|
| 35 |
#' @export |
|
| 36 |
#' |
|
| 37 |
#' @examples |
|
| 38 |
#' \dontrun{
|
|
| 39 |
#' # Create network with 4 clusters |
|
| 40 |
#' nodes <- paste0("N", 1:20)
|
|
| 41 |
#' m <- matrix(runif(400, 0, 0.3), 20, 20) |
|
| 42 |
#' diag(m) <- 0 |
|
| 43 |
#' colnames(m) <- rownames(m) <- nodes |
|
| 44 |
#' |
|
| 45 |
#' clusters <- list( |
|
| 46 |
#' North = paste0("N", 1:5),
|
|
| 47 |
#' East = paste0("N", 6:10),
|
|
| 48 |
#' South = paste0("N", 11:15),
|
|
| 49 |
#' West = paste0("N", 16:20)
|
|
| 50 |
#' ) |
|
| 51 |
#' |
|
| 52 |
#' # Summary edges between clusters + individual edges within |
|
| 53 |
#' plot_mtna(m, clusters, summary_edges = TRUE) |
|
| 54 |
#' |
|
| 55 |
#' # Control spacing and sizes |
|
| 56 |
#' plot_mtna(m, clusters, spacing = 4, shape_size = 1.5, node_spacing = 0.6) |
|
| 57 |
#' } |
|
| 58 |
plot_mtna <- function( |
|
| 59 |
x, |
|
| 60 |
cluster_list, |
|
| 61 |
layout = "circle", |
|
| 62 |
spacing = 3, |
|
| 63 |
shape_size = 1.2, |
|
| 64 |
node_spacing = 0.5, |
|
| 65 |
colors = NULL, |
|
| 66 |
shapes = NULL, |
|
| 67 |
edge_colors = NULL, |
|
| 68 |
bundle_edges = TRUE, |
|
| 69 |
bundle_strength = 0.8, |
|
| 70 |
summary_edges = TRUE, |
|
| 71 |
within_edges = TRUE, |
|
| 72 |
show_border = TRUE, |
|
| 73 |
legend = TRUE, |
|
| 74 |
legend_position = "topright", |
|
| 75 |
curvature = 0.3, |
|
| 76 |
node_size = 2, |
|
| 77 |
scale = 1, |
|
| 78 |
... |
|
| 79 |
) {
|
|
| 80 |
# Apply scale for high-resolution output |
|
| 81 | 81x |
size_scale <- sqrt(scale) |
| 82 | 81x |
node_size <- node_size / size_scale |
| 83 | 81x |
edge_scale <- 1 / size_scale |
| 84 | ||
| 85 | 81x |
dots <- list(...) |
| 86 | 81x |
edge_lwd_mult <- if (!is.null(dots$edge.lwd)) dots$edge.lwd else 1 |
| 87 | ||
| 88 |
# Validate cluster_list |
|
| 89 | 81x |
n_clusters <- length(cluster_list) |
| 90 | 81x |
if (!is.list(cluster_list) || n_clusters < 2) {
|
| 91 | 2x |
stop("cluster_list must be a list of 2+ character vectors", call. = FALSE)
|
| 92 |
} |
|
| 93 | ||
| 94 |
# Get labels and weights from x |
|
| 95 | 79x |
if (inherits(x, "tna")) {
|
| 96 | 11x |
lab <- x$labels |
| 97 | 11x |
weights <- x$weights |
| 98 | 68x |
} else if (is.matrix(x)) {
|
| 99 | 67x |
lab <- colnames(x) |
| 100 | 1x |
if (is.null(lab)) lab <- as.character(seq_len(ncol(x))) |
| 101 | 67x |
weights <- x |
| 102 |
} else {
|
|
| 103 | 1x |
stop("x must be a tna object or matrix", call. = FALSE)
|
| 104 |
} |
|
| 105 | ||
| 106 | 78x |
n <- length(lab) |
| 107 | ||
| 108 |
# Validate no overlap between clusters |
|
| 109 | 78x |
all_nodes <- unlist(cluster_list) |
| 110 | 78x |
if (anyDuplicated(all_nodes)) {
|
| 111 | 1x |
dups <- all_nodes[duplicated(all_nodes)] |
| 112 | 1x |
stop("cluster_list groups must not overlap. Duplicates: ",
|
| 113 | 1x |
paste(unique(dups), collapse = ", "), call. = FALSE) |
| 114 |
} |
|
| 115 | ||
| 116 |
# Get indices for each cluster |
|
| 117 | 77x |
cluster_indices <- lapply(cluster_list, function(nodes) {
|
| 118 | 173x |
idx <- match(nodes, lab) |
| 119 | 173x |
if (any(is.na(idx))) {
|
| 120 | 1x |
missing <- nodes[is.na(idx)] |
| 121 | 1x |
stop("Nodes not found in x: ", paste(missing, collapse = ", "), call. = FALSE)
|
| 122 |
} |
|
| 123 | 172x |
idx |
| 124 |
}) |
|
| 125 | ||
| 126 |
# Color palettes |
|
| 127 | 76x |
color_palette <- c("#ffd89d", "#a68ba5", "#7eb5d6", "#98d4a2",
|
| 128 | 76x |
"#f4a582", "#92c5de", "#d6c1de", "#b8e186", |
| 129 | 76x |
"#fdcdac", "#cbd5e8", "#f4cae4", "#e6f5c9") |
| 130 | ||
| 131 | 76x |
shape_palette <- c("circle", "square", "diamond", "triangle",
|
| 132 | 76x |
"pentagon", "hexagon", "star", "cross") |
| 133 | ||
| 134 | 76x |
edge_color_palette <- c("#e6a500", "#7a5a7a", "#4a90b8", "#5cb85c",
|
| 135 | 76x |
"#d9534f", "#5bc0de", "#9b59b6", "#8bc34a", |
| 136 | 76x |
"#ff7043", "#78909c", "#ab47bc", "#aed581") |
| 137 | ||
| 138 |
# Set colors and shapes |
|
| 139 | 76x |
cluster_colors <- if (is.null(colors)) rep_len(color_palette, n_clusters) else colors |
| 140 | 76x |
cluster_shapes <- if (is.null(shapes)) rep_len(shape_palette, n_clusters) else shapes |
| 141 | 76x |
if (is.null(edge_colors)) {
|
| 142 | 75x |
edge_colors <- rep_len(edge_color_palette, n_clusters) |
| 143 |
} |
|
| 144 | ||
| 145 |
# Compute cluster center positions |
|
| 146 | 76x |
cluster_centers <- switch(layout, |
| 147 | 76x |
"circle" = {
|
| 148 | 66x |
angles <- pi/2 - (seq_len(n_clusters) - 1) * 2 * pi / n_clusters |
| 149 | 66x |
cbind( |
| 150 | 66x |
x = spacing * cos(angles), |
| 151 | 66x |
y = spacing * sin(angles) |
| 152 |
) |
|
| 153 |
}, |
|
| 154 | 76x |
"grid" = {
|
| 155 | 3x |
nc <- ceiling(sqrt(n_clusters)) |
| 156 | 3x |
nr <- ceiling(n_clusters / nc) |
| 157 | 3x |
expand.grid( |
| 158 | 3x |
x = seq(0, (nc - 1) * spacing * 2, length.out = nc), |
| 159 | 3x |
y = seq(0, -(nr - 1) * spacing * 2, length.out = nr) |
| 160 | 3x |
)[seq_len(n_clusters), ] |
| 161 |
}, |
|
| 162 | 76x |
"horizontal" = {
|
| 163 | 3x |
cbind( |
| 164 | 3x |
x = seq(0, (n_clusters - 1) * spacing * 2, length.out = n_clusters), |
| 165 | 3x |
y = 0 |
| 166 |
) |
|
| 167 |
}, |
|
| 168 | 76x |
"vertical" = {
|
| 169 | 3x |
cbind( |
| 170 | 3x |
x = 0, |
| 171 | 3x |
y = seq(0, -(n_clusters - 1) * spacing * 2, length.out = n_clusters) |
| 172 |
) |
|
| 173 |
}, |
|
| 174 | 76x |
stop("Unknown layout: ", layout, call. = FALSE)
|
| 175 |
) |
|
| 176 | ||
| 177 |
# Initialize node positions |
|
| 178 | 75x |
x_pos <- rep(0, n) |
| 179 | 75x |
y_pos <- rep(0, n) |
| 180 | ||
| 181 |
# Assign node colors and shapes |
|
| 182 | 75x |
colors <- rep("lightgray", n)
|
| 183 | 75x |
shapes <- rep("circle", n)
|
| 184 | ||
| 185 |
# Place nodes in circular clusters |
|
| 186 |
# If bundling, position nodes based on their inter-cluster connectivity |
|
| 187 | 75x |
for (i in seq_len(n_clusters)) {
|
| 188 | 170x |
idx <- cluster_indices[[i]] |
| 189 | 170x |
n_nodes <- length(idx) |
| 190 | 170x |
center_x <- cluster_centers[i, 1] |
| 191 | 170x |
center_y <- cluster_centers[i, 2] |
| 192 | ||
| 193 | 170x |
if (bundle_edges && n_nodes > 1) {
|
| 194 |
# Calculate optimal angle for each node based on connections to other clusters |
|
| 195 | 135x |
node_angles <- numeric(n_nodes) |
| 196 | ||
| 197 | 135x |
for (j in seq_len(n_nodes)) {
|
| 198 | 500x |
node_idx <- idx[j] |
| 199 |
# Find which other clusters this node connects to most |
|
| 200 | 500x |
target_angles <- numeric(0) |
| 201 | 500x |
target_weights <- numeric(0) |
| 202 | ||
| 203 | 500x |
for (k in seq_len(n_clusters)) {
|
| 204 | 1113x |
if (k != i) {
|
| 205 | 613x |
other_idx <- cluster_indices[[k]] |
| 206 |
# Sum of edge weights to this cluster |
|
| 207 | 613x |
out_weight <- sum(weights[node_idx, other_idx], na.rm = TRUE) |
| 208 | 613x |
in_weight <- sum(weights[other_idx, node_idx], na.rm = TRUE) |
| 209 | 613x |
total_weight <- out_weight + in_weight |
| 210 | ||
| 211 | 613x |
if (total_weight > 0) {
|
| 212 |
# Angle from this cluster center to other cluster center |
|
| 213 | 591x |
dx <- cluster_centers[k, 1] - center_x |
| 214 | 591x |
dy <- cluster_centers[k, 2] - center_y |
| 215 | 591x |
angle_to_cluster <- atan2(dy, dx) |
| 216 | 591x |
target_angles <- c(target_angles, angle_to_cluster) |
| 217 | 591x |
target_weights <- c(target_weights, total_weight) |
| 218 |
} |
|
| 219 |
} |
|
| 220 |
} |
|
| 221 | ||
| 222 |
# Weighted average angle (or default if no connections) |
|
| 223 | 500x |
if (length(target_angles) > 0 && sum(target_weights) > 0) {
|
| 224 |
# Use circular mean weighted by connection strength |
|
| 225 | 495x |
wx <- sum(target_weights * cos(target_angles)) / sum(target_weights) |
| 226 | 495x |
wy <- sum(target_weights * sin(target_angles)) / sum(target_weights) |
| 227 | 495x |
node_angles[j] <- atan2(wy, wx) |
| 228 |
} else {
|
|
| 229 |
# Default: evenly distributed starting angle |
|
| 230 | 5x |
node_angles[j] <- pi/2 - (j - 1) * 2 * pi / n_nodes |
| 231 |
} |
|
| 232 |
} |
|
| 233 | ||
| 234 |
# Sort nodes by their preferred angle |
|
| 235 | 135x |
angle_order <- order(node_angles) |
| 236 | ||
| 237 |
# Distribute nodes evenly around the circle but in sorted order |
|
| 238 |
# This keeps nodes with similar targets near each other |
|
| 239 | 135x |
even_angles <- pi/2 - (seq_len(n_nodes) - 1) * 2 * pi / n_nodes |
| 240 | ||
| 241 | 135x |
for (j in seq_len(n_nodes)) {
|
| 242 | 500x |
orig_idx <- angle_order[j] |
| 243 | 500x |
final_angle <- even_angles[j] |
| 244 | ||
| 245 | 500x |
x_pos[idx[orig_idx]] <- center_x + shape_size * cos(final_angle) |
| 246 | 500x |
y_pos[idx[orig_idx]] <- center_y + shape_size * sin(final_angle) |
| 247 |
} |
|
| 248 | 35x |
} else if (n_nodes > 1) {
|
| 249 |
# No bundling - arrange evenly |
|
| 250 | 6x |
angles <- pi/2 - (seq_len(n_nodes) - 1) * 2 * pi / n_nodes |
| 251 | 6x |
x_pos[idx] <- center_x + shape_size * cos(angles) |
| 252 | 6x |
y_pos[idx] <- center_y + shape_size * sin(angles) |
| 253 |
} else {
|
|
| 254 | 29x |
x_pos[idx] <- center_x |
| 255 | 29x |
y_pos[idx] <- center_y |
| 256 |
} |
|
| 257 | ||
| 258 |
# Set colors and shapes |
|
| 259 | 170x |
colors[idx] <- cluster_colors[i] |
| 260 | 170x |
shapes[idx] <- cluster_shapes[i] |
| 261 |
} |
|
| 262 | ||
| 263 |
# Create node-to-cluster mapping for edge colors |
|
| 264 | 75x |
node_to_cluster <- rep(NA, n) |
| 265 | 75x |
for (i in seq_len(n_clusters)) {
|
| 266 | 170x |
node_to_cluster[cluster_indices[[i]]] <- i |
| 267 |
} |
|
| 268 | ||
| 269 |
# Build edge color matrix |
|
| 270 | 75x |
edge_color_matrix <- matrix(NA, nrow = n, ncol = n) |
| 271 | 75x |
for (i in seq_len(n)) {
|
| 272 | 553x |
src_cluster <- node_to_cluster[i] |
| 273 | 553x |
if (!is.na(src_cluster)) {
|
| 274 | 553x |
edge_color_matrix[i, ] <- edge_colors[src_cluster] |
| 275 |
} |
|
| 276 |
} |
|
| 277 | ||
| 278 | 75x |
layout_mat <- cbind(x = x_pos, y = y_pos) |
| 279 | ||
| 280 |
# Handle summary edges mode |
|
| 281 | 75x |
if (summary_edges) {
|
| 282 |
# Create aggregated cluster-to-cluster weight matrix |
|
| 283 | 71x |
cluster_weights <- matrix(0, nrow = n_clusters, ncol = n_clusters) |
| 284 | 71x |
for (i in seq_len(n_clusters)) {
|
| 285 | 162x |
for (j in seq_len(n_clusters)) {
|
| 286 | 398x |
if (i != j) {
|
| 287 |
# Sum all edges from cluster i to cluster j |
|
| 288 | 236x |
cluster_weights[i, j] <- sum(weights[cluster_indices[[i]], cluster_indices[[j]]], na.rm = TRUE) |
| 289 |
} |
|
| 290 |
} |
|
| 291 |
} |
|
| 292 | ||
| 293 |
# Create cluster-level layout (centers) |
|
| 294 | 71x |
cluster_layout <- as.matrix(cluster_centers) |
| 295 | 71x |
colnames(cluster_layout) <- c("x", "y")
|
| 296 | ||
| 297 |
# Cluster names |
|
| 298 | 71x |
cluster_names <- names(cluster_list) |
| 299 | 71x |
if (is.null(cluster_names)) {
|
| 300 | 3x |
cluster_names <- paste0("Cluster ", seq_len(n_clusters))
|
| 301 |
} |
|
| 302 | 71x |
colnames(cluster_weights) <- rownames(cluster_weights) <- cluster_names |
| 303 | ||
| 304 |
# Build cluster edge colors |
|
| 305 | 71x |
cluster_edge_colors <- matrix(NA, nrow = n_clusters, ncol = n_clusters) |
| 306 | 71x |
for (i in seq_len(n_clusters)) {
|
| 307 | 162x |
cluster_edge_colors[i, ] <- edge_colors[i] |
| 308 |
} |
|
| 309 | ||
| 310 |
# For summary view, we need to draw manually after setting up the plot |
|
| 311 |
# First create empty plot with correct dimensions |
|
| 312 | 71x |
all_x <- cluster_centers[, 1] |
| 313 | 71x |
all_y <- cluster_centers[, 2] |
| 314 | 71x |
x_range <- range(all_x) + c(-shape_size * 2, shape_size * 2) |
| 315 | 71x |
y_range <- range(all_y) + c(-shape_size * 2, shape_size * 2) |
| 316 | ||
| 317 |
# Set up blank plot |
|
| 318 | 71x |
graphics::plot.new() |
| 319 | 71x |
graphics::plot.window(xlim = x_range, ylim = y_range, asp = 1) |
| 320 | ||
| 321 |
# Helper function to find edge point on shell border |
|
| 322 | 71x |
get_shell_edge_point <- function(center_x, center_y, target_x, target_y, radius, shape) {
|
| 323 |
# Direction from center to target |
|
| 324 | 468x |
dx <- target_x - center_x |
| 325 | 468x |
dy <- target_y - center_y |
| 326 | 468x |
angle <- atan2(dy, dx) |
| 327 | ||
| 328 | 468x |
if (shape == "circle") {
|
| 329 |
# Circle: point on circumference |
|
| 330 | 154x |
return(c(center_x + radius * cos(angle), |
| 331 | 154x |
center_y + radius * sin(angle))) |
| 332 | 314x |
} else if (shape == "square") {
|
| 333 |
# Square: find intersection with square border |
|
| 334 |
# Normalize direction |
|
| 335 | 166x |
if (abs(dx) > abs(dy)) {
|
| 336 |
# Hits left or right side |
|
| 337 | 30x |
edge_x <- center_x + sign(dx) * radius |
| 338 | 30x |
edge_y <- center_y + dy / abs(dx) * radius |
| 339 |
} else {
|
|
| 340 |
# Hits top or bottom side |
|
| 341 | 136x |
edge_y <- center_y + sign(dy) * radius |
| 342 | 136x |
edge_x <- center_x + dx / abs(dy) * radius |
| 343 |
} |
|
| 344 | 166x |
return(c(edge_x, edge_y)) |
| 345 | 148x |
} else if (shape == "diamond") {
|
| 346 |
# Diamond: intersection with rotated square |
|
| 347 |
# For diamond, sum of |x| + |y| = radius (in local coords) |
|
| 348 | 66x |
abs_cos <- abs(cos(angle)) |
| 349 | 66x |
abs_sin <- abs(sin(angle)) |
| 350 | 66x |
scale <- radius / (abs_cos + abs_sin) |
| 351 | 66x |
return(c(center_x + scale * cos(angle), |
| 352 | 66x |
center_y + scale * sin(angle))) |
| 353 | 82x |
} else if (shape == "triangle") {
|
| 354 |
# Triangle with vertices at top, bottom-left, bottom-right |
|
| 355 |
# Vertices at angles: pi/2, pi/2 + 2*pi/3, pi/2 + 4*pi/3 |
|
| 356 | 74x |
vertex_angles <- c(pi/2, pi/2 + 2*pi/3, pi/2 + 4*pi/3) |
| 357 | ||
| 358 |
# Normalize angle to [0, 2*pi) |
|
| 359 | 74x |
norm_angle <- angle %% (2 * pi) |
| 360 | ! |
if (norm_angle < 0) norm_angle <- norm_angle + 2 * pi |
| 361 | ||
| 362 |
# Find which edge we're hitting |
|
| 363 |
# Edge midpoint angles are between vertices |
|
| 364 | 74x |
edge_mid_angles <- c( |
| 365 | 74x |
pi/2 + pi/3, # between top and bottom-left (5*pi/6) |
| 366 | 74x |
pi/2 + pi, # between bottom-left and bottom-right (3*pi/2) |
| 367 | 74x |
pi/2 + 5*pi/3 # between bottom-right and top (pi/6 or 13*pi/6) |
| 368 |
) |
|
| 369 | ||
| 370 |
# For regular polygon: distance = r * cos(pi/n) / cos(angle - edge_center_angle) |
|
| 371 |
# For triangle n=3, cos(pi/3) = 0.5 |
|
| 372 | 74x |
apothem_ratio <- cos(pi/3) # = 0.5 |
| 373 | ||
| 374 |
# Find which sector the angle falls into |
|
| 375 |
# Sectors are centered on edge midpoints |
|
| 376 | 74x |
if (norm_angle >= pi/6 && norm_angle < 5*pi/6) {
|
| 377 |
# Right side of top or left edge |
|
| 378 | 30x |
if (norm_angle < pi/2) {
|
| 379 |
# Right edge (from bottom-right to top) |
|
| 380 | 8x |
edge_center <- pi/6 |
| 381 |
} else {
|
|
| 382 |
# Left edge (from top to bottom-left) |
|
| 383 | 22x |
edge_center <- 5*pi/6 |
| 384 |
} |
|
| 385 | 44x |
} else if (norm_angle >= 5*pi/6 && norm_angle < 3*pi/2) {
|
| 386 |
# Left edge or bottom edge |
|
| 387 | 22x |
if (norm_angle < 7*pi/6) {
|
| 388 | 14x |
edge_center <- 5*pi/6 |
| 389 |
} else {
|
|
| 390 | 8x |
edge_center <- 3*pi/2 |
| 391 |
} |
|
| 392 |
} else {
|
|
| 393 |
# Bottom or right edge |
|
| 394 | 22x |
if (norm_angle >= 3*pi/2 || norm_angle < pi/6) {
|
| 395 | 22x |
if (norm_angle >= 3*pi/2 && norm_angle < 11*pi/6) {
|
| 396 | 16x |
edge_center <- 3*pi/2 |
| 397 |
} else {
|
|
| 398 | 6x |
edge_center <- pi/6 |
| 399 | ! |
if (norm_angle > pi) edge_center <- edge_center + 2*pi |
| 400 |
} |
|
| 401 |
} else {
|
|
| 402 | ! |
edge_center <- pi/6 |
| 403 |
} |
|
| 404 |
} |
|
| 405 | ||
| 406 |
# Calculate distance using apothem formula |
|
| 407 | 74x |
angle_diff <- abs(norm_angle - edge_center) |
| 408 | ! |
if (angle_diff > pi) angle_diff <- 2*pi - angle_diff |
| 409 | ||
| 410 |
# Clamp to avoid division issues near vertices |
|
| 411 | 74x |
angle_diff <- min(angle_diff, pi/3 - 0.01) |
| 412 | ||
| 413 | 74x |
scale <- radius * apothem_ratio / cos(angle_diff) |
| 414 | 74x |
return(c(center_x + scale * cos(angle), |
| 415 | 74x |
center_y + scale * sin(angle))) |
| 416 |
} else {
|
|
| 417 |
# Default: circle |
|
| 418 | 8x |
return(c(center_x + radius * cos(angle), |
| 419 | 8x |
center_y + radius * sin(angle))) |
| 420 |
} |
|
| 421 |
} |
|
| 422 | ||
| 423 | 71x |
shell_radius <- shape_size |
| 424 |
# Use slightly smaller radius for edge endpoints to touch the border |
|
| 425 | 71x |
edge_radius <- shell_radius * 0.98 |
| 426 | ||
| 427 |
# STEP 1: Draw summary edges FIRST (behind everything) |
|
| 428 | 71x |
for (i in seq_len(n_clusters)) {
|
| 429 | 162x |
for (j in seq_len(n_clusters)) {
|
| 430 | 398x |
if (i != j && cluster_weights[i, j] > 0) {
|
| 431 |
# Get edge start point on shell i border (facing cluster j) |
|
| 432 | 234x |
start_pt <- get_shell_edge_point( |
| 433 | 234x |
cluster_centers[i, 1], cluster_centers[i, 2], |
| 434 | 234x |
cluster_centers[j, 1], cluster_centers[j, 2], |
| 435 | 234x |
edge_radius, cluster_shapes[i] |
| 436 |
) |
|
| 437 | 234x |
x0 <- start_pt[1] |
| 438 | 234x |
y0 <- start_pt[2] |
| 439 | ||
| 440 |
# Get edge end point on shell j border (facing cluster i) |
|
| 441 | 234x |
end_pt <- get_shell_edge_point( |
| 442 | 234x |
cluster_centers[j, 1], cluster_centers[j, 2], |
| 443 | 234x |
cluster_centers[i, 1], cluster_centers[i, 2], |
| 444 | 234x |
edge_radius, cluster_shapes[j] |
| 445 |
) |
|
| 446 | 234x |
x1 <- end_pt[1] |
| 447 | 234x |
y1 <- end_pt[2] |
| 448 | ||
| 449 |
# Edge weight determines line width |
|
| 450 | 234x |
weight <- cluster_weights[i, j] |
| 451 | 234x |
max_weight <- max(cluster_weights, na.rm = TRUE) |
| 452 | 234x |
lwd <- (0.5 + 2.5 * (weight / max_weight)) * edge_scale * edge_lwd_mult |
| 453 | ||
| 454 |
# Draw curved line using xspline |
|
| 455 | 234x |
mid_x <- (x0 + x1) / 2 |
| 456 | 234x |
mid_y <- (y0 + y1) / 2 |
| 457 |
# Perpendicular offset for curve |
|
| 458 | 234x |
dx <- x1 - x0 |
| 459 | 234x |
dy <- y1 - y0 |
| 460 | 234x |
len <- sqrt(dx^2 + dy^2) |
| 461 | 234x |
if (len > 0) {
|
| 462 |
# Offset perpendicular to line |
|
| 463 | 234x |
off_x <- -dy / len * curvature * len * 0.3 |
| 464 | 234x |
off_y <- dx / len * curvature * len * 0.3 |
| 465 |
} else {
|
|
| 466 | ! |
off_x <- 0 |
| 467 | ! |
off_y <- 0 |
| 468 |
} |
|
| 469 | ||
| 470 | 234x |
graphics::xspline( |
| 471 | 234x |
x = c(x0, mid_x + off_x, x1), |
| 472 | 234x |
y = c(y0, mid_y + off_y, y1), |
| 473 | 234x |
shape = 1, |
| 474 | 234x |
open = TRUE, |
| 475 | 234x |
border = edge_colors[i], |
| 476 | 234x |
lwd = lwd |
| 477 |
) |
|
| 478 | ||
| 479 |
# Draw arrowhead at the end |
|
| 480 | 234x |
if (len > 0) {
|
| 481 | 234x |
angle <- atan2(y1 - (mid_y + off_y), x1 - (mid_x + off_x)) |
| 482 | 234x |
arrow_len <- 0.15 |
| 483 | 234x |
graphics::polygon( |
| 484 | 234x |
x = x1 + arrow_len * c(0, -cos(angle - pi/7), -cos(angle + pi/7)), |
| 485 | 234x |
y = y1 + arrow_len * c(0, -sin(angle - pi/7), -sin(angle + pi/7)), |
| 486 | 234x |
col = edge_colors[i], |
| 487 | 234x |
border = edge_colors[i] |
| 488 |
) |
|
| 489 |
} |
|
| 490 | ||
| 491 |
# Draw edge label |
|
| 492 | 234x |
dots <- list(...) |
| 493 | 234x |
if (is.null(dots$edge.labels) || !isFALSE(dots$edge.labels)) {
|
| 494 | 232x |
label_cex <- if (!is.null(dots$edge.label.cex)) dots$edge.label.cex else 0.6 |
| 495 | 232x |
graphics::text(mid_x + off_x * 1.3, mid_y + off_y * 1.3, |
| 496 | 232x |
labels = round(weight, 2), |
| 497 | 232x |
cex = label_cex, |
| 498 | 232x |
col = "gray40") |
| 499 |
} |
|
| 500 |
} |
|
| 501 |
} |
|
| 502 |
} |
|
| 503 | ||
| 504 |
# STEP 2: Draw shell fills and borders (on top of summary edges) |
|
| 505 | 71x |
for (i in seq_len(n_clusters)) {
|
| 506 | 162x |
center_x <- cluster_centers[i, 1] |
| 507 | 162x |
center_y <- cluster_centers[i, 2] |
| 508 | 162x |
shape <- cluster_shapes[i] |
| 509 | 162x |
shell_color <- cluster_colors[i] |
| 510 |
# Use light fill to cover summary edges underneath |
|
| 511 | 162x |
fill_color <- grDevices::adjustcolor(shell_color, alpha.f = 0.2) |
| 512 | ||
| 513 | 162x |
if (shape == "circle") {
|
| 514 | 61x |
theta <- seq(0, 2 * pi, length.out = 100) |
| 515 | 61x |
graphics::polygon( |
| 516 | 61x |
x = center_x + shell_radius * cos(theta), |
| 517 | 61x |
y = center_y + shell_radius * sin(theta), |
| 518 | 61x |
border = shell_color, |
| 519 | 61x |
col = fill_color, |
| 520 | 61x |
lwd = 1.5 * edge_scale |
| 521 |
) |
|
| 522 | 101x |
} else if (shape == "square") {
|
| 523 | 66x |
graphics::rect( |
| 524 | 66x |
xleft = center_x - shell_radius, |
| 525 | 66x |
ybottom = center_y - shell_radius, |
| 526 | 66x |
xright = center_x + shell_radius, |
| 527 | 66x |
ytop = center_y + shell_radius, |
| 528 | 66x |
border = shell_color, |
| 529 | 66x |
col = fill_color, |
| 530 | 66x |
lwd = 1.5 * edge_scale |
| 531 |
) |
|
| 532 | 35x |
} else if (shape == "diamond") {
|
| 533 | 17x |
graphics::polygon( |
| 534 | 17x |
x = center_x + shell_radius * c(0, 1, 0, -1, 0), |
| 535 | 17x |
y = center_y + shell_radius * c(1, 0, -1, 0, 1), |
| 536 | 17x |
border = shell_color, |
| 537 | 17x |
col = fill_color, |
| 538 | 17x |
lwd = 1.5 * edge_scale |
| 539 |
) |
|
| 540 | 18x |
} else if (shape == "triangle") {
|
| 541 | 14x |
angles <- c(pi/2, pi/2 + 2*pi/3, pi/2 + 4*pi/3, pi/2) |
| 542 | 14x |
graphics::polygon( |
| 543 | 14x |
x = center_x + shell_radius * cos(angles), |
| 544 | 14x |
y = center_y + shell_radius * sin(angles), |
| 545 | 14x |
border = shell_color, |
| 546 | 14x |
col = fill_color, |
| 547 | 14x |
lwd = 1.5 * edge_scale |
| 548 |
) |
|
| 549 |
} else {
|
|
| 550 | 4x |
theta <- seq(0, 2 * pi, length.out = 100) |
| 551 | 4x |
graphics::polygon( |
| 552 | 4x |
x = center_x + shell_radius * cos(theta), |
| 553 | 4x |
y = center_y + shell_radius * sin(theta), |
| 554 | 4x |
border = shell_color, |
| 555 | 4x |
col = fill_color, |
| 556 | 4x |
lwd = 1.5 * edge_scale |
| 557 |
) |
|
| 558 |
} |
|
| 559 |
} |
|
| 560 | ||
| 561 |
# STEP 3: Draw within-cluster edges (if enabled) |
|
| 562 | 71x |
if (isTRUE(within_edges)) {
|
| 563 | 69x |
dots <- list(...) |
| 564 | 69x |
min_weight <- if (!is.null(dots$minimum)) dots$minimum else 0 |
| 565 | ||
| 566 | 69x |
for (i in seq_len(n_clusters)) {
|
| 567 | 158x |
center_x <- cluster_centers[i, 1] |
| 568 | 158x |
center_y <- cluster_centers[i, 2] |
| 569 | 158x |
idx <- cluster_indices[[i]] |
| 570 | 158x |
n_nodes <- length(idx) |
| 571 | 158x |
shell_color <- cluster_colors[i] |
| 572 | ||
| 573 | 158x |
if (n_nodes > 1) {
|
| 574 | 129x |
inner_radius <- shape_size * node_spacing |
| 575 | 129x |
node_angles <- pi/2 - (seq_len(n_nodes) - 1) * 2 * pi / n_nodes |
| 576 | 129x |
inner_x <- center_x + inner_radius * cos(node_angles) |
| 577 | 129x |
inner_y <- center_y + inner_radius * sin(node_angles) |
| 578 | ||
| 579 |
# Draw edges within this cluster |
|
| 580 | 129x |
for (j in seq_len(n_nodes)) {
|
| 581 | 476x |
for (k in seq_len(n_nodes)) {
|
| 582 | 1810x |
if (j != k) {
|
| 583 | 1334x |
src_idx <- idx[j] |
| 584 | 1334x |
tgt_idx <- idx[k] |
| 585 | 1334x |
weight <- weights[src_idx, tgt_idx] |
| 586 | ||
| 587 | 1334x |
if (!is.na(weight) && weight > min_weight) {
|
| 588 | 702x |
x0 <- inner_x[j] |
| 589 | 702x |
y0 <- inner_y[j] |
| 590 | 702x |
x1 <- inner_x[k] |
| 591 | 702x |
y1 <- inner_y[k] |
| 592 | ||
| 593 |
# Edge width based on weight |
|
| 594 | 702x |
max_within <- max(weights[idx, idx], na.rm = TRUE) |
| 595 | 702x |
if (max_within > 0) {
|
| 596 | 702x |
lwd <- (0.3 + 1.0 * (weight / max_within)) * edge_scale * edge_lwd_mult |
| 597 |
} else {
|
|
| 598 | ! |
lwd <- 0.5 * edge_scale * edge_lwd_mult |
| 599 |
} |
|
| 600 | ||
| 601 |
# Curved edge |
|
| 602 | 702x |
mid_x <- (x0 + x1) / 2 |
| 603 | 702x |
mid_y <- (y0 + y1) / 2 |
| 604 | 702x |
dx <- x1 - x0 |
| 605 | 702x |
dy <- y1 - y0 |
| 606 | 702x |
len <- sqrt(dx^2 + dy^2) |
| 607 | ||
| 608 | 702x |
if (len > 0) {
|
| 609 | 702x |
off_x <- -dy / len * curvature * len * 0.4 |
| 610 | 702x |
off_y <- dx / len * curvature * len * 0.4 |
| 611 | ||
| 612 |
# Darker shade of cluster color for edges |
|
| 613 | 702x |
edge_col <- grDevices::adjustcolor(shell_color, red.f = 0.7, green.f = 0.7, blue.f = 0.7) |
| 614 | ||
| 615 | 702x |
graphics::xspline( |
| 616 | 702x |
x = c(x0, mid_x + off_x, x1), |
| 617 | 702x |
y = c(y0, mid_y + off_y, y1), |
| 618 | 702x |
shape = 1, |
| 619 | 702x |
open = TRUE, |
| 620 | 702x |
border = edge_col, |
| 621 | 702x |
lwd = lwd |
| 622 |
) |
|
| 623 | ||
| 624 |
# Small arrowhead |
|
| 625 | 702x |
angle <- atan2(y1 - (mid_y + off_y), x1 - (mid_x + off_x)) |
| 626 | 702x |
arrow_len <- 0.06 |
| 627 | 702x |
graphics::polygon( |
| 628 | 702x |
x = x1 + arrow_len * c(0, -cos(angle - pi/7), -cos(angle + pi/7)), |
| 629 | 702x |
y = y1 + arrow_len * c(0, -sin(angle - pi/7), -sin(angle + pi/7)), |
| 630 | 702x |
col = edge_col, |
| 631 | 702x |
border = edge_col |
| 632 |
) |
|
| 633 |
} |
|
| 634 |
} |
|
| 635 |
} |
|
| 636 |
} |
|
| 637 |
} |
|
| 638 |
} |
|
| 639 |
} |
|
| 640 |
} |
|
| 641 | ||
| 642 |
# STEP 4: Draw nodes inside shells and labels |
|
| 643 | 71x |
for (i in seq_len(n_clusters)) {
|
| 644 | 162x |
center_x <- cluster_centers[i, 1] |
| 645 | 162x |
center_y <- cluster_centers[i, 2] |
| 646 | 162x |
idx <- cluster_indices[[i]] |
| 647 | 162x |
n_nodes <- length(idx) |
| 648 | 162x |
shape <- cluster_shapes[i] |
| 649 | 162x |
shell_color <- cluster_colors[i] |
| 650 | ||
| 651 |
# Draw nodes inside the shell |
|
| 652 | 162x |
if (n_nodes > 1) {
|
| 653 | 133x |
inner_radius <- shape_size * node_spacing |
| 654 | 133x |
node_angles <- pi/2 - (seq_len(n_nodes) - 1) * 2 * pi / n_nodes |
| 655 | 133x |
inner_x <- center_x + inner_radius * cos(node_angles) |
| 656 | 133x |
inner_y <- center_y + inner_radius * sin(node_angles) |
| 657 |
} else {
|
|
| 658 | 29x |
inner_x <- center_x |
| 659 | 29x |
inner_y <- center_y |
| 660 |
} |
|
| 661 | ||
| 662 |
# Map shape to pch |
|
| 663 | 162x |
shape_to_pch <- c( |
| 664 | 162x |
"circle" = 21, "square" = 22, "diamond" = 23, "triangle" = 24, |
| 665 | 162x |
"pentagon" = 21, "hexagon" = 21, "star" = 8, "cross" = 3 |
| 666 |
) |
|
| 667 | 162x |
pch_val <- if (shape %in% names(shape_to_pch)) shape_to_pch[shape] else 21 |
| 668 | ||
| 669 |
# Draw nodes |
|
| 670 | 162x |
graphics::points(inner_x, inner_y, |
| 671 | 162x |
pch = pch_val, |
| 672 | 162x |
bg = shell_color, |
| 673 | 162x |
col = "gray30", |
| 674 | 162x |
cex = node_size) |
| 675 | ||
| 676 |
# Draw cluster label |
|
| 677 | 162x |
cluster_names <- names(cluster_list) |
| 678 | 162x |
if (!is.null(cluster_names)) {
|
| 679 | 156x |
graphics::text(center_x, center_y - shell_radius - 0.2, |
| 680 | 156x |
labels = cluster_names[i], |
| 681 | 156x |
cex = 1 / size_scale, |
| 682 | 156x |
col = shell_color, |
| 683 | 156x |
font = 2) |
| 684 |
} |
|
| 685 |
} |
|
| 686 | ||
| 687 | 71x |
result <- NULL |
| 688 |
} else {
|
|
| 689 |
# Regular mode - show all individual edges |
|
| 690 | 4x |
dots <- list(...) |
| 691 | 4x |
dots$edge.color <- NULL |
| 692 | ||
| 693 | 4x |
tplot_args <- c( |
| 694 | 4x |
list( |
| 695 | 4x |
x = x, |
| 696 | 4x |
layout = layout_mat, |
| 697 | 4x |
color = colors, |
| 698 | 4x |
node_shape = shapes, |
| 699 | 4x |
curvature = curvature, |
| 700 | 4x |
edge.color = edge_color_matrix |
| 701 |
), |
|
| 702 | 4x |
dots |
| 703 |
) |
|
| 704 | ||
| 705 | 4x |
result <- do.call(plot_tna, tplot_args) |
| 706 | ||
| 707 |
# Draw cluster borders |
|
| 708 | 4x |
if (show_border) {
|
| 709 | 4x |
for (i in seq_len(n_clusters)) {
|
| 710 | 8x |
center_x <- cluster_centers[i, 1] |
| 711 | 8x |
center_y <- cluster_centers[i, 2] |
| 712 | ||
| 713 |
# Draw border circle |
|
| 714 | 8x |
theta <- seq(0, 2 * pi, length.out = 100) |
| 715 | 8x |
border_radius <- shape_size * 1.1 |
| 716 | 8x |
graphics::polygon( |
| 717 | 8x |
x = center_x + border_radius * cos(theta), |
| 718 | 8x |
y = center_y + border_radius * sin(theta), |
| 719 | 8x |
border = cluster_colors[i], |
| 720 | 8x |
col = NA, |
| 721 | 8x |
lwd = 2 * edge_scale, |
| 722 | 8x |
lty = 2 |
| 723 |
) |
|
| 724 |
} |
|
| 725 |
} |
|
| 726 |
} |
|
| 727 | ||
| 728 |
# Draw legend |
|
| 729 | 75x |
if (isTRUE(legend)) {
|
| 730 | 73x |
cluster_names <- names(cluster_list) |
| 731 | 73x |
if (is.null(cluster_names)) {
|
| 732 | 3x |
cluster_names <- paste0("Cluster ", seq_len(n_clusters))
|
| 733 |
} |
|
| 734 | ||
| 735 | 73x |
shape_to_pch <- c( |
| 736 | 73x |
"circle" = 21, "square" = 22, "diamond" = 23, "triangle" = 24, |
| 737 | 73x |
"pentagon" = 21, "hexagon" = 21, "star" = 8, "cross" = 3 |
| 738 |
) |
|
| 739 | 73x |
pch_values <- sapply(cluster_shapes, function(s) {
|
| 740 | 2x |
if (s %in% names(shape_to_pch)) shape_to_pch[s] else 21 |
| 741 |
}) |
|
| 742 | ||
| 743 | 73x |
graphics::legend( |
| 744 | 73x |
legend_position, |
| 745 | 73x |
legend = cluster_names, |
| 746 | 73x |
pch = pch_values, |
| 747 | 73x |
pt.bg = cluster_colors, |
| 748 | 73x |
col = edge_colors, |
| 749 | 73x |
pt.cex = 1.5 / size_scale, |
| 750 | 73x |
cex = 0.8 / size_scale, |
| 751 | 73x |
bty = "n", |
| 752 | 73x |
title = "Clusters" |
| 753 |
) |
|
| 754 |
} |
|
| 755 | ||
| 756 | 75x |
invisible(result) |
| 757 |
} |
|
| 758 | ||
| 759 |
#' @rdname plot_mtna |
|
| 760 |
#' @export |
|
| 761 |
mtna <- plot_mtna |
| 1 |
#' TNA-Style Network Plot (qgraph Compatible) |
|
| 2 |
#' |
|
| 3 |
#' A drop-in replacement for qgraph::qgraph() that uses cograph's splot engine. |
|
| 4 |
#' Accepts qgraph parameter names for seamless migration from qgraph to cograph. |
|
| 5 |
#' |
|
| 6 |
#' @param x A weight matrix (adjacency matrix) or tna object |
|
| 7 |
#' @param color Node fill colors |
|
| 8 |
#' @param labels Node labels |
|
| 9 |
#' @param layout Layout: "circle", "spring", "oval", or a coordinate matrix |
|
| 10 |
#' @param theme Plot theme ("colorblind", "gray", etc.)
|
|
| 11 |
#' @param mar Plot margins (numeric vector of length 4) |
|
| 12 |
#' @param cut Edge emphasis threshold |
|
| 13 |
#' @param edge.labels Show edge weight labels |
|
| 14 |
#' @param edge.label.position Position of edge labels along edge (0-1) |
|
| 15 |
#' @param edge.label.cex Edge label size multiplier |
|
| 16 |
#' @param edge.color Edge colors |
|
| 17 |
#' @param vsize Node size |
|
| 18 |
#' @param pie Pie/donut fill values (e.g., initial probabilities) |
|
| 19 |
#' @param pieColor Pie/donut segment colors |
|
| 20 |
#' @param lty Line type for edges (1=solid, 2=dashed, 3=dotted) |
|
| 21 |
#' @param directed Logical, is the graph directed? |
|
| 22 |
#' @param minimum Minimum edge weight to display |
|
| 23 |
#' @param posCol Color for positive edges |
|
| 24 |
#' @param negCol Color for negative edges |
|
| 25 |
#' @param arrowAngle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 26 |
#' @param title Plot title |
|
| 27 |
#' @param ... Additional arguments passed to splot() |
|
| 28 |
#' |
|
| 29 |
#' @return Invisibly returns the cograph_network object from splot(). |
|
| 30 |
#' |
|
| 31 |
#' @export |
|
| 32 |
#' |
|
| 33 |
#' @examples |
|
| 34 |
#' # Simple usage |
|
| 35 |
#' m <- matrix(runif(25), 5, 5) |
|
| 36 |
#' plot_tna(m) |
|
| 37 |
#' |
|
| 38 |
#' # With qgraph-style parameters |
|
| 39 |
#' plot_tna(m, vsize = 15, edge.label.cex = 2, layout = "circle") |
|
| 40 |
#' |
|
| 41 |
#' # With custom colors |
|
| 42 |
#' plot_tna(m, color = rainbow(5), vsize = 10) |
|
| 43 |
#' |
|
| 44 |
plot_tna <- function( |
|
| 45 |
x, |
|
| 46 |
color = NULL, |
|
| 47 |
labels = NULL, |
|
| 48 |
layout = "oval", |
|
| 49 |
theme = "colorblind", |
|
| 50 |
mar = c(0.1, 0.1, 0.1, 0.1), |
|
| 51 |
cut = NULL, |
|
| 52 |
edge.labels = TRUE, |
|
| 53 |
edge.label.position = 0.7, |
|
| 54 |
edge.label.cex = 0.6, |
|
| 55 |
edge.color = "#003355", |
|
| 56 |
vsize = 7, |
|
| 57 |
pie = NULL, |
|
| 58 |
pieColor = NULL, |
|
| 59 |
lty = NULL, |
|
| 60 |
directed = TRUE, |
|
| 61 |
minimum = NULL, |
|
| 62 |
posCol = NULL, |
|
| 63 |
negCol = NULL, |
|
| 64 |
arrowAngle = NULL, |
|
| 65 |
title = NULL, |
|
| 66 |
... |
|
| 67 |
) {
|
|
| 68 |
# Build splot arguments |
|
| 69 | 106x |
splot_args <- list( |
| 70 | 106x |
x = x, |
| 71 | 106x |
directed = directed |
| 72 |
) |
|
| 73 | ||
| 74 |
# Node parameters |
|
| 75 | 85x |
if (!is.null(color)) splot_args$node_fill <- color |
| 76 | 1x |
if (!is.null(labels)) splot_args$labels <- labels |
| 77 | 106x |
splot_args$node_size <- vsize |
| 78 | ||
| 79 |
# Donut/pie parameters (qgraph pie = numeric vector 0-1) |
|
| 80 | 2x |
if (!is.null(pie)) splot_args$donut_fill <- pie |
| 81 | 1x |
if (!is.null(pieColor)) splot_args$donut_color <- pieColor |
| 82 | ||
| 83 |
# Edge parameters |
|
| 84 | 106x |
splot_args$edge_labels <- edge.labels |
| 85 | 106x |
splot_args$edge_label_position <- edge.label.position |
| 86 | 106x |
splot_args$edge_label_size <- edge.label.cex |
| 87 | 106x |
if (!is.null(edge.color)) splot_args$edge_color <- edge.color |
| 88 | 1x |
if (!is.null(posCol)) splot_args$edge_positive_color <- posCol |
| 89 | 1x |
if (!is.null(negCol)) splot_args$edge_negative_color <- negCol |
| 90 | ||
| 91 |
# Edge filtering |
|
| 92 | 1x |
if (!is.null(cut)) splot_args$edge_cutoff <- cut |
| 93 | 1x |
if (!is.null(minimum)) splot_args$threshold <- minimum |
| 94 | ||
| 95 |
# Layout and margins |
|
| 96 | 106x |
splot_args$layout <- layout |
| 97 | 106x |
splot_args$margins <- mar |
| 98 | 106x |
splot_args$theme <- theme |
| 99 | ||
| 100 |
# Title |
|
| 101 | 1x |
if (!is.null(title)) splot_args$title <- title |
| 102 | ||
| 103 |
# Line type mapping: qgraph lty (1=solid, 2=dashed, 3=dotted) |
|
| 104 | 106x |
if (!is.null(lty) && length(lty) > 0) {
|
| 105 | 2x |
lty_map <- c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash")
|
| 106 | 2x |
if (is.numeric(lty)) {
|
| 107 | 1x |
splot_args$edge_style <- lty_map[pmin(lty, 6)] |
| 108 |
} else {
|
|
| 109 | 1x |
splot_args$edge_style <- lty |
| 110 |
} |
|
| 111 |
} |
|
| 112 | ||
| 113 |
# TNA defaults for edge styling |
|
| 114 | 106x |
splot_args$edge_start_style <- "dotted" |
| 115 | 106x |
splot_args$edge_start_length <- 0.2 |
| 116 | 106x |
splot_args$arrow_size <- 0.61 |
| 117 | ||
| 118 |
# Arrow angle |
|
| 119 | 1x |
if (!is.null(arrowAngle)) splot_args$arrow_angle <- arrowAngle |
| 120 | ||
| 121 |
# Call splot |
|
| 122 | 106x |
do.call(splot, c(splot_args, list(...))) |
| 123 |
} |
|
| 124 | ||
| 125 |
#' @rdname plot_tna |
|
| 126 |
#' @export |
|
| 127 |
tplot <- plot_tna |
| 1 |
#' @title Base R Graphics Geometry Utilities |
|
| 2 |
#' @description Coordinate transformation and geometry functions for splot(). |
|
| 3 |
#' @name splot-geometry |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Convert User Coordinates to Inches (X-axis) |
|
| 8 |
#' |
|
| 9 |
#' @param x Value in user coordinates. |
|
| 10 |
#' @return Value in inches. |
|
| 11 |
#' @keywords internal |
|
| 12 |
usr_to_in_x <- function(x) {
|
|
| 13 | 1x |
usr <- graphics::par("usr")
|
| 14 | 1x |
pin <- graphics::par("pin")
|
| 15 | 1x |
(x - usr[1]) / (usr[2] - usr[1]) * pin[1] |
| 16 |
} |
|
| 17 | ||
| 18 |
#' Convert User Coordinates to Inches (Y-axis) |
|
| 19 |
#' |
|
| 20 |
#' @param y Value in user coordinates. |
|
| 21 |
#' @return Value in inches. |
|
| 22 |
#' @keywords internal |
|
| 23 |
usr_to_in_y <- function(y) {
|
|
| 24 | 1x |
usr <- graphics::par("usr")
|
| 25 | 1x |
pin <- graphics::par("pin")
|
| 26 | 1x |
(y - usr[3]) / (usr[4] - usr[3]) * pin[2] |
| 27 |
} |
|
| 28 | ||
| 29 |
#' Convert Inches to User Coordinates (X-axis) |
|
| 30 |
#' |
|
| 31 |
#' @param x Value in inches. |
|
| 32 |
#' @return Value in user coordinates. |
|
| 33 |
#' @keywords internal |
|
| 34 |
in_to_usr_x <- function(x) {
|
|
| 35 | 1x |
usr <- graphics::par("usr")
|
| 36 | 1x |
pin <- graphics::par("pin")
|
| 37 | 1x |
x / pin[1] * (usr[2] - usr[1]) + usr[1] |
| 38 |
} |
|
| 39 | ||
| 40 |
#' Convert Inches to User Coordinates (Y-axis) |
|
| 41 |
#' |
|
| 42 |
#' @param y Value in inches. |
|
| 43 |
#' @return Value in user coordinates. |
|
| 44 |
#' @keywords internal |
|
| 45 |
in_to_usr_y <- function(y) {
|
|
| 46 | 1x |
usr <- graphics::par("usr")
|
| 47 | 1x |
pin <- graphics::par("pin")
|
| 48 | 1x |
y / pin[2] * (usr[4] - usr[3]) + usr[3] |
| 49 |
} |
|
| 50 | ||
| 51 |
#' Get X-axis Scale Factor (inches per user unit) |
|
| 52 |
#' |
|
| 53 |
#' @return Scale factor. |
|
| 54 |
#' @keywords internal |
|
| 55 |
get_x_scale <- function() {
|
|
| 56 | 5557x |
usr <- graphics::par("usr")
|
| 57 | 5557x |
pin <- graphics::par("pin")
|
| 58 | 5557x |
pin[1] / (usr[2] - usr[1]) |
| 59 |
} |
|
| 60 | ||
| 61 |
#' Get Y-axis Scale Factor (inches per user unit) |
|
| 62 |
#' |
|
| 63 |
#' @return Scale factor. |
|
| 64 |
#' @keywords internal |
|
| 65 |
get_y_scale <- function() {
|
|
| 66 | 5557x |
usr <- graphics::par("usr")
|
| 67 | 5557x |
pin <- graphics::par("pin")
|
| 68 | 5557x |
pin[2] / (usr[4] - usr[3]) |
| 69 |
} |
|
| 70 | ||
| 71 |
#' Aspect-Corrected atan2 |
|
| 72 |
#' |
|
| 73 |
#' Calculate angle accounting for aspect ratio differences. |
|
| 74 |
#' |
|
| 75 |
#' @param dy Change in y (user coordinates). |
|
| 76 |
#' @param dx Change in x (user coordinates). |
|
| 77 |
#' @return Angle in radians. |
|
| 78 |
#' @keywords internal |
|
| 79 |
atan2_usr <- function(dy, dx) {
|
|
| 80 |
# Convert to inches to get visually correct angle |
|
| 81 | 1x |
dy_in <- dy * get_y_scale() |
| 82 | 1x |
dx_in <- dx * get_x_scale() |
| 83 | 1x |
atan2(dy_in, dx_in) |
| 84 |
} |
|
| 85 | ||
| 86 |
#' Calculate Point on Node Boundary |
|
| 87 |
#' |
|
| 88 |
#' Given a node center, size, and angle, calculates the point on the node |
|
| 89 |
#' boundary. Works with various shapes. |
|
| 90 |
#' |
|
| 91 |
#' @param x Node center x coordinate. |
|
| 92 |
#' @param y Node center y coordinate. |
|
| 93 |
#' @param angle Angle in radians. |
|
| 94 |
#' @param cex Node size (radius in user coordinates). |
|
| 95 |
#' @param cex2 Secondary size for ellipse width (NULL for square aspect). |
|
| 96 |
#' @param shape Node shape: "circle", "square", "ellipse", or polygon name. |
|
| 97 |
#' @return List with x, y coordinates on boundary. |
|
| 98 |
#' @keywords internal |
|
| 99 |
cent_to_edge <- function(x, y, angle, cex, cex2 = NULL, shape = "circle") {
|
|
| 100 | ||
| 101 |
# Defensive checks for invalid inputs |
|
| 102 | 5551x |
if (length(x) == 0 || length(y) == 0 || length(angle) == 0 || length(cex) == 0) {
|
| 103 | 1x |
return(list(x = numeric(0), y = numeric(0))) |
| 104 |
} |
|
| 105 | 5550x |
if (is.na(x) || is.na(y) || is.na(angle) || is.na(cex)) {
|
| 106 | 1x |
return(list(x = NA_real_, y = NA_real_)) |
| 107 |
} |
|
| 108 | ||
| 109 |
# Get aspect correction |
|
| 110 | 5549x |
x_scale <- get_x_scale() |
| 111 | 5549x |
y_scale <- get_y_scale() |
| 112 | 5549x |
asp <- y_scale / x_scale |
| 113 | ||
| 114 | 5547x |
if (is.null(cex2)) cex2 <- cex |
| 115 | ||
| 116 |
# Handle NA or empty shape |
|
| 117 | 1x |
if (length(shape) == 0 || is.na(shape)) shape <- "circle" |
| 118 | ||
| 119 | 5549x |
if (shape == "circle") {
|
| 120 |
# Circle: simple radial point |
|
| 121 | 4037x |
list( |
| 122 | 4037x |
x = x + cex * cos(angle), |
| 123 | 4037x |
y = y + cex * sin(angle) |
| 124 |
) |
|
| 125 | ||
| 126 | 1512x |
} else if (shape == "square" || shape == "rectangle") {
|
| 127 |
# Square/rectangle: find intersection with edges |
|
| 128 |
# Normalize angle to [0, 2*pi) |
|
| 129 | 772x |
a <- angle %% (2 * pi) |
| 130 | ||
| 131 |
# Half-widths |
|
| 132 | 772x |
hw <- cex # half-width |
| 133 | 772x |
hh <- cex2 # half-height |
| 134 | ||
| 135 |
# Determine which edge we hit |
|
| 136 |
# Using tangent to find intersection |
|
| 137 | 772x |
tan_a <- tan(a) |
| 138 | ||
| 139 | 772x |
if (abs(cos(a)) < 1e-10) {
|
| 140 |
# Vertical (top or bottom) |
|
| 141 | 170x |
if (sin(a) > 0) {
|
| 142 | 90x |
list(x = x, y = y + hh) |
| 143 |
} else {
|
|
| 144 | 80x |
list(x = x, y = y - hh) |
| 145 |
} |
|
| 146 | 602x |
} else if (abs(sin(a)) < 1e-10) {
|
| 147 |
# Horizontal (left or right) |
|
| 148 | 181x |
if (cos(a) > 0) {
|
| 149 | 67x |
list(x = x + hw, y = y) |
| 150 |
} else {
|
|
| 151 | 114x |
list(x = x - hw, y = y) |
| 152 |
} |
|
| 153 |
} else {
|
|
| 154 |
# General case |
|
| 155 |
# Check right/left edge |
|
| 156 | 421x |
edge_x <- if (cos(a) > 0) hw else -hw |
| 157 | 421x |
edge_y <- edge_x * tan_a |
| 158 | ||
| 159 | 421x |
if (abs(edge_y) <= hh) {
|
| 160 | 230x |
list(x = x + edge_x, y = y + edge_y) |
| 161 |
} else {
|
|
| 162 |
# Top/bottom edge |
|
| 163 | 191x |
edge_y <- if (sin(a) > 0) hh else -hh |
| 164 | 191x |
edge_x <- edge_y / tan_a |
| 165 | 191x |
list(x = x + edge_x, y = y + edge_y) |
| 166 |
} |
|
| 167 |
} |
|
| 168 | ||
| 169 | 740x |
} else if (shape == "ellipse") {
|
| 170 |
# Ellipse: parametric boundary point |
|
| 171 |
# For ellipse with semi-axes a (horizontal) and b (vertical) |
|
| 172 | 19x |
a <- cex # horizontal radius |
| 173 | 19x |
b <- cex2 # vertical radius |
| 174 | ||
| 175 |
# Point on ellipse at angle (not quite the same as the parametric angle) |
|
| 176 |
# Use Newton's method or direct formula |
|
| 177 |
# Simple approximation using parametric form |
|
| 178 | 19x |
list( |
| 179 | 19x |
x = x + a * cos(angle), |
| 180 | 19x |
y = y + b * sin(angle) |
| 181 |
) |
|
| 182 | ||
| 183 |
} else {
|
|
| 184 |
# Default to circle for unknown shapes |
|
| 185 | 721x |
list( |
| 186 | 721x |
x = x + cex * cos(angle), |
| 187 | 721x |
y = y + cex * sin(angle) |
| 188 |
) |
|
| 189 |
} |
|
| 190 |
} |
|
| 191 | ||
| 192 |
#' Calculate Perpendicular Midpoint for Curved Edges |
|
| 193 |
#' |
|
| 194 |
#' Computes a control point perpendicular to the line between two nodes, |
|
| 195 |
#' used for xspline() curve generation. |
|
| 196 |
#' |
|
| 197 |
#' @param x0 Start x coordinate. |
|
| 198 |
#' @param y0 Start y coordinate. |
|
| 199 |
#' @param x1 End x coordinate. |
|
| 200 |
#' @param y1 End y coordinate. |
|
| 201 |
#' @param cex Curvature amount (positive = left, negative = right). |
|
| 202 |
#' @param q Position along edge (0 = start, 0.5 = middle, 1 = end). |
|
| 203 |
#' @return List with x, y coordinates of control point. |
|
| 204 |
#' @keywords internal |
|
| 205 |
perp_mid <- function(x0, y0, x1, y1, cex, q = 0.5) {
|
|
| 206 |
# Point along the edge |
|
| 207 | 7x |
mx <- x0 + q * (x1 - x0) |
| 208 | 7x |
my <- y0 + q * (y1 - y0) |
| 209 | ||
| 210 |
# Edge vector |
|
| 211 | 7x |
dx <- x1 - x0 |
| 212 | 7x |
dy <- y1 - y0 |
| 213 | 7x |
len <- sqrt(dx^2 + dy^2) |
| 214 | ||
| 215 |
# Defensive check for empty or NA values |
|
| 216 | 7x |
if (length(len) == 0 || is.na(len) || len < 1e-10) {
|
| 217 | 1x |
return(list(x = mx, y = my)) |
| 218 |
} |
|
| 219 | ||
| 220 |
# Perpendicular unit vector (rotated 90 degrees counterclockwise) |
|
| 221 | 6x |
px <- -dy / len |
| 222 | 6x |
py <- dx / len |
| 223 | ||
| 224 |
# Get aspect correction to make curve look circular |
|
| 225 | 6x |
x_scale <- get_x_scale() |
| 226 | 6x |
y_scale <- get_y_scale() |
| 227 | ||
| 228 |
# Offset distance (scaled by edge length for consistent appearance) |
|
| 229 | 6x |
offset <- cex * len |
| 230 | ||
| 231 | 6x |
list( |
| 232 | 6x |
x = mx + offset * px, |
| 233 | 6x |
y = my + offset * py |
| 234 |
) |
|
| 235 |
} |
|
| 236 | ||
| 237 |
#' Calculate Distance Between Two Points |
|
| 238 |
#' |
|
| 239 |
#' @param x1,y1 First point. |
|
| 240 |
#' @param x2,y2 Second point. |
|
| 241 |
#' @return Euclidean distance. |
|
| 242 |
#' @keywords internal |
|
| 243 |
splot_distance <- function(x1, y1, x2, y2) {
|
|
| 244 | 5x |
sqrt((x2 - x1)^2 + (y2 - y1)^2) |
| 245 |
} |
|
| 246 | ||
| 247 |
#' Calculate Angle Between Two Points |
|
| 248 |
#' |
|
| 249 |
#' @param x1,y1 Start point. |
|
| 250 |
#' @param x2,y2 End point. |
|
| 251 |
#' @return Angle in radians. |
|
| 252 |
#' @keywords internal |
|
| 253 |
splot_angle <- function(x1, y1, x2, y2) {
|
|
| 254 | 8443x |
atan2(y2 - y1, x2 - x1) |
| 255 |
} |
|
| 256 | ||
| 257 |
#' Rescale Layout to -1 to 1 Range |
|
| 258 |
#' |
|
| 259 |
#' @param layout Matrix or data frame with x, y columns. |
|
| 260 |
#' @param mar Margin to leave (as proportion of range). |
|
| 261 |
#' @return Rescaled layout. |
|
| 262 |
#' @keywords internal |
|
| 263 |
rescale_layout <- function(layout, mar = 0.1) {
|
|
| 264 | 667x |
layout <- as.data.frame(layout) |
| 265 | ||
| 266 | 667x |
if (ncol(layout) < 2) {
|
| 267 | 1x |
stop("Layout must have at least 2 columns", call. = FALSE)
|
| 268 |
} |
|
| 269 | ||
| 270 | 666x |
x <- layout[[1]] |
| 271 | 666x |
y <- layout[[2]] |
| 272 | ||
| 273 |
# Get ranges |
|
| 274 | 666x |
x_range <- range(x, na.rm = TRUE) |
| 275 | 666x |
y_range <- range(y, na.rm = TRUE) |
| 276 | ||
| 277 |
# Handle constant values |
|
| 278 | 666x |
if (diff(x_range) < 1e-10) {
|
| 279 | 15x |
x_range <- x_range + c(-1, 1) |
| 280 |
} |
|
| 281 | 666x |
if (diff(y_range) < 1e-10) {
|
| 282 | 6x |
y_range <- y_range + c(-1, 1) |
| 283 |
} |
|
| 284 | ||
| 285 |
# Target range with margins |
|
| 286 | 666x |
target <- 1 - mar |
| 287 | ||
| 288 |
# Rescale using uniform scaling to preserve aspect ratio |
|
| 289 | 666x |
max_range <- max(diff(x_range), diff(y_range)) |
| 290 | 666x |
x_center <- mean(x_range) |
| 291 | 666x |
y_center <- mean(y_range) |
| 292 | 666x |
layout[[1]] <- (x - x_center) / max_range * 2 * target |
| 293 | 666x |
layout[[2]] <- (y - y_center) / max_range * 2 * target |
| 294 | ||
| 295 | 666x |
layout |
| 296 |
} |
| 1 |
#' Plot Heterogeneous TNA Network (Multi-Group Layout) |
|
| 2 |
#' |
|
| 3 |
#' Plots a TNA model with nodes arranged in multiple groups using geometric layouts: |
|
| 4 |
#' \itemize{
|
|
| 5 |
#' \item 2 groups: Bipartite (two vertical columns or horizontal rows) |
|
| 6 |
#' \item 3+ groups: Polygon (nodes along edges of a regular polygon) |
|
| 7 |
#' } |
|
| 8 |
#' Supports triangle (3), rectangle (4), pentagon (5), hexagon (6), and beyond. |
|
| 9 |
#' |
|
| 10 |
#' @param x A tna object or weight matrix. |
|
| 11 |
#' @param node_list List of 2+ character vectors defining node groups. |
|
| 12 |
#' @param layout Layout type: "auto" (default), "bipartite", "polygon", or "circular". |
|
| 13 |
#' When "auto", uses bipartite for 2 groups and polygon for 3+ groups. |
|
| 14 |
#' "circular" places groups along arcs of a circle. |
|
| 15 |
#' Legacy values "triangle" and "rectangle" are supported as aliases for "polygon". |
|
| 16 |
#' @param use_list_order Logical. Use node_list order (TRUE) or weight-based order (FALSE). |
|
| 17 |
#' Only applies to bipartite layout. |
|
| 18 |
#' @param jitter Controls horizontal spread of nodes. Options: |
|
| 19 |
#' \itemize{
|
|
| 20 |
#' \item TRUE (default): Auto-compute jitter based on edge connectivity |
|
| 21 |
#' \item FALSE or 0: No jitter (nodes aligned in columns) |
|
| 22 |
#' \item Numeric (0-1): Amount of jitter (0.3 = spread nodes 30\% of column width) |
|
| 23 |
#' \item Named list: Manual per-node offsets by label (e.g., list(Wrong = -0.2)) |
|
| 24 |
#' \item Numeric vector of length n: Direct x-offsets for each node |
|
| 25 |
#' } |
|
| 26 |
#' Only applies to bipartite layout. |
|
| 27 |
#' @param jitter_amount Base jitter amount when jitter=TRUE. Default 0.5. |
|
| 28 |
#' Higher values spread nodes more toward the center. Only applies to bipartite layout. |
|
| 29 |
#' @param jitter_side Which side(s) to apply jitter: "first", "second", "both", or "none". |
|
| 30 |
#' Default "first" (only first group nodes are jittered toward center). |
|
| 31 |
#' Only applies to bipartite layout. |
|
| 32 |
#' @param orientation Layout orientation for bipartite: "vertical" (two columns, default) |
|
| 33 |
#' or "horizontal" (two rows). Ignored for triangle/rectangle layouts. |
|
| 34 |
#' @param group1_pos Position for first group in bipartite layout. Default -1.2. |
|
| 35 |
#' @param group2_pos Position for second group in bipartite layout. Default 1.2. |
|
| 36 |
#' @param curvature Edge curvature amount. Default 0.4 for visible curves. |
|
| 37 |
#' @param group1_color Color for first group nodes. Default "#ffd89d". |
|
| 38 |
#' @param group2_color Color for second group nodes. Default "#a68ba5". |
|
| 39 |
#' @param group1_shape Shape for first group nodes. Default "circle". |
|
| 40 |
#' @param group2_shape Shape for second group nodes. Default "square". |
|
| 41 |
#' @param group_colors Vector of colors for each group. Overrides group1_color/group2_color. |
|
| 42 |
#' Required for 3+ groups if not using defaults. |
|
| 43 |
#' @param group_shapes Vector of shapes for each group. Overrides group1_shape/group2_shape. |
|
| 44 |
#' Required for 3+ groups if not using defaults. |
|
| 45 |
#' @param angle_spacing Controls empty space at corners (0-1). Default 0.15. |
|
| 46 |
#' Higher values create larger empty angles at vertices. Only applies to triangle/rectangle layouts. |
|
| 47 |
#' @param edge_colors Vector of colors for edges by source group. If NULL (default), |
|
| 48 |
#' uses darker versions of group_colors. Set to FALSE to use default edge color. |
|
| 49 |
#' @param legend Logical. Whether to show a legend. Default TRUE for polygon layouts. |
|
| 50 |
#' @param legend_position Position for legend: "topright", "topleft", "bottomright", |
|
| 51 |
#' "bottomleft", "right", "left", "top", "bottom". Default "topright". |
|
| 52 |
#' @param extend_lines Logical or numeric. Draw extension lines from nodes. |
|
| 53 |
#' Only applies to bipartite layout. |
|
| 54 |
#' \itemize{
|
|
| 55 |
#' \item FALSE (default): No extension lines |
|
| 56 |
#' \item TRUE: Draw lines extending toward the other group (default length 0.1) |
|
| 57 |
#' \item Numeric: Length of extension lines |
|
| 58 |
#' } |
|
| 59 |
#' @param ... Additional parameters passed to tplot(). |
|
| 60 |
#' |
|
| 61 |
#' @return Invisibly returns the result from tplot(). |
|
| 62 |
#' |
|
| 63 |
#' @export |
|
| 64 |
#' |
|
| 65 |
#' @examples |
|
| 66 |
#' \dontrun{
|
|
| 67 |
#' # Define node groups (2 groups - bipartite) |
|
| 68 |
#' node_types <- list( |
|
| 69 |
#' Student = c("Wrong", "Retry", "Right", "Attempt", "Instruction", "Skip"),
|
|
| 70 |
#' AI = c("Order", "Correct", "Hint", "Quit", "Clarify", "Question", "Praise")
|
|
| 71 |
#' ) |
|
| 72 |
#' |
|
| 73 |
#' # Basic bipartite plot |
|
| 74 |
#' plot_htna(model, node_types) |
|
| 75 |
#' |
|
| 76 |
#' # With custom jitter |
|
| 77 |
#' plot_htna(model, node_types, jitter_amount = 0.5) |
|
| 78 |
#' |
|
| 79 |
#' # Triangle layout (3 groups) |
|
| 80 |
#' node_types_3 <- list( |
|
| 81 |
#' Teacher = c("Explain", "Question", "Feedback"),
|
|
| 82 |
#' Student = c("Answer", "Ask", "Attempt"),
|
|
| 83 |
#' System = c("Hint", "Score", "Progress")
|
|
| 84 |
#' ) |
|
| 85 |
#' plot_htna(model, node_types_3) # Auto-detects triangle |
|
| 86 |
#' |
|
| 87 |
#' # Rectangle layout (4 groups) |
|
| 88 |
#' node_types_4 <- list( |
|
| 89 |
#' Input = c("Click", "Type", "Scroll"),
|
|
| 90 |
#' Process = c("Validate", "Transform"),
|
|
| 91 |
#' Output = c("Display", "Alert"),
|
|
| 92 |
#' Storage = c("Save", "Load", "Cache")
|
|
| 93 |
#' ) |
|
| 94 |
#' plot_htna(model, node_types_4) # Auto-detects rectangle |
|
| 95 |
#' |
|
| 96 |
#' # Explicit layout selection |
|
| 97 |
#' plot_htna(model, node_types_3, layout = "triangle") |
|
| 98 |
#' } |
|
| 99 |
plot_htna <- function( |
|
| 100 |
x, |
|
| 101 |
node_list, |
|
| 102 |
layout = "auto", |
|
| 103 |
use_list_order = TRUE, |
|
| 104 |
jitter = TRUE, |
|
| 105 |
jitter_amount = 0.8, |
|
| 106 |
jitter_side = "first", |
|
| 107 |
orientation = "vertical", |
|
| 108 |
group1_pos = -1.2, |
|
| 109 |
group2_pos = 1.2, |
|
| 110 |
curvature = 0.4, |
|
| 111 |
group1_color = "#ffd89d", |
|
| 112 |
group2_color = "#a68ba5", |
|
| 113 |
group1_shape = "circle", |
|
| 114 |
group2_shape = "square", |
|
| 115 |
group_colors = NULL, |
|
| 116 |
group_shapes = NULL, |
|
| 117 |
angle_spacing = 0.15, |
|
| 118 |
edge_colors = NULL, |
|
| 119 |
legend = TRUE, |
|
| 120 |
legend_position = "topright", |
|
| 121 |
extend_lines = FALSE, |
|
| 122 |
scale = 1, |
|
| 123 |
... |
|
| 124 |
) {
|
|
| 125 |
# Apply scale for high-resolution output |
|
| 126 | 92x |
size_scale <- sqrt(scale) |
| 127 | ||
| 128 |
# Extended color palette for many groups |
|
| 129 | 92x |
color_palette <- c("#ffd89d", "#a68ba5", "#7eb5d6", "#98d4a2",
|
| 130 | 92x |
"#f4a582", "#92c5de", "#d6c1de", "#b8e186", |
| 131 | 92x |
"#fdcdac", "#cbd5e8", "#f4cae4", "#e6f5c9") |
| 132 | ||
| 133 |
# Extended shape palette |
|
| 134 | 92x |
shape_palette <- c("circle", "square", "diamond", "triangle",
|
| 135 | 92x |
"pentagon", "hexagon", "star", "cross") |
| 136 | ||
| 137 |
# Validate node_list |
|
| 138 | 92x |
n_groups <- length(node_list) |
| 139 | 92x |
if (!is.list(node_list) || n_groups < 2) {
|
| 140 | 4x |
stop("node_list must be a list of 2+ character vectors", call. = FALSE)
|
| 141 |
} |
|
| 142 | 88x |
for (i in seq_along(node_list)) {
|
| 143 | 214x |
if (!is.character(node_list[[i]])) {
|
| 144 | 1x |
stop("node_list elements must be character vectors", call. = FALSE)
|
| 145 |
} |
|
| 146 |
} |
|
| 147 | ||
| 148 |
# Get labels and weights from x |
|
| 149 | 87x |
if (inherits(x, "tna")) {
|
| 150 | 1x |
lab <- x$labels |
| 151 | 1x |
weights <- x$weights |
| 152 | 86x |
} else if (is.matrix(x)) {
|
| 153 | 85x |
lab <- colnames(x) |
| 154 | 2x |
if (is.null(lab)) lab <- as.character(seq_len(ncol(x))) |
| 155 | 85x |
weights <- x |
| 156 |
} else {
|
|
| 157 | 1x |
stop("x must be a tna object or matrix", call. = FALSE)
|
| 158 |
} |
|
| 159 | ||
| 160 | 86x |
n <- length(lab) |
| 161 | ||
| 162 |
# Validate no overlap between groups |
|
| 163 | 86x |
all_nodes <- unlist(node_list) |
| 164 | 86x |
if (anyDuplicated(all_nodes)) {
|
| 165 | 1x |
dups <- all_nodes[duplicated(all_nodes)] |
| 166 | 1x |
stop("node_list groups must not overlap. Duplicates: ",
|
| 167 | 1x |
paste(unique(dups), collapse = ", "), call. = FALSE) |
| 168 |
} |
|
| 169 | ||
| 170 |
# Get indices for each group and validate |
|
| 171 | ||
| 172 | 85x |
group_indices <- lapply(node_list, function(nodes) {
|
| 173 | 208x |
idx <- match(nodes, lab) |
| 174 | 208x |
if (any(is.na(idx))) {
|
| 175 | 1x |
missing <- nodes[is.na(idx)] |
| 176 | 1x |
stop("Nodes not found in x: ", paste(missing, collapse = ", "), call. = FALSE)
|
| 177 |
} |
|
| 178 | 207x |
idx |
| 179 |
}) |
|
| 180 | ||
| 181 |
# Determine layout type |
|
| 182 | 84x |
if (layout == "auto") {
|
| 183 | 62x |
layout <- if (n_groups == 2) "bipartite" else "polygon" |
| 184 |
} |
|
| 185 | ||
| 186 | ||
| 187 |
# Map legacy layout names to polygon |
|
| 188 | 84x |
if (layout %in% c("triangle", "rectangle", "pentagon", "hexagon")) {
|
| 189 | 3x |
layout <- "polygon" |
| 190 |
} |
|
| 191 | ||
| 192 |
# Validate layout matches group count |
|
| 193 | 84x |
if (layout == "bipartite" && n_groups != 2) {
|
| 194 | 1x |
stop("Bipartite layout requires exactly 2 groups", call. = FALSE)
|
| 195 |
} |
|
| 196 | 83x |
if (layout == "polygon" && n_groups < 3) {
|
| 197 | 1x |
stop("Polygon layout requires at least 3 groups", call. = FALSE)
|
| 198 |
} |
|
| 199 |
# Note: circular with < 2 groups is already caught by the n_groups < 2 check above |
|
| 200 | ||
| 201 |
# Determine colors and shapes for each group |
|
| 202 | 82x |
if (is.null(group_colors)) {
|
| 203 | 80x |
if (n_groups == 2) {
|
| 204 |
# Use individual parameters for backward compatibility |
|
| 205 | 54x |
group_colors <- c(group1_color, group2_color) |
| 206 |
} else {
|
|
| 207 |
# Cycle through palette if more groups than colors |
|
| 208 | 26x |
group_colors <- rep_len(color_palette, n_groups) |
| 209 |
} |
|
| 210 |
} |
|
| 211 | 82x |
if (is.null(group_shapes)) {
|
| 212 | 78x |
if (n_groups == 2) {
|
| 213 |
# Use individual parameters for backward compatibility |
|
| 214 | 54x |
group_shapes <- c(group1_shape, group2_shape) |
| 215 |
} else {
|
|
| 216 |
# Cycle through palette if more groups than shapes |
|
| 217 | 24x |
group_shapes <- rep_len(shape_palette, n_groups) |
| 218 |
} |
|
| 219 |
} |
|
| 220 | ||
| 221 |
# Validate color/shape vectors |
|
| 222 | ||
| 223 | 82x |
if (length(group_colors) != n_groups) {
|
| 224 | 1x |
stop("group_colors must have ", n_groups, " elements", call. = FALSE)
|
| 225 |
} |
|
| 226 | 81x |
if (length(group_shapes) != n_groups) {
|
| 227 | 1x |
stop("group_shapes must have ", n_groups, " elements", call. = FALSE)
|
| 228 |
} |
|
| 229 | ||
| 230 |
# Assign colors and shapes to nodes |
|
| 231 | 80x |
colors <- rep("lightgray", n)
|
| 232 | 80x |
shapes <- rep("circle", n)
|
| 233 | 80x |
for (i in seq_along(node_list)) {
|
| 234 | 196x |
idx <- group_indices[[i]] |
| 235 | 196x |
colors[idx] <- group_colors[i] |
| 236 | 196x |
shapes[idx] <- group_shapes[i] |
| 237 |
} |
|
| 238 | ||
| 239 |
# Initialize positions |
|
| 240 | 80x |
x_pos <- rep(0, n) |
| 241 | 80x |
y_pos <- rep(0, n) |
| 242 | ||
| 243 |
# Route to appropriate layout computation |
|
| 244 | 80x |
if (layout == "bipartite") {
|
| 245 |
# For bipartite, use group_indices directly |
|
| 246 | 50x |
lhs_idx <- group_indices[[1]] |
| 247 | 50x |
rhs_idx <- group_indices[[2]] |
| 248 | 50x |
n_g1 <- length(lhs_idx) |
| 249 | 50x |
n_g2 <- length(rhs_idx) |
| 250 | ||
| 251 |
# Map jitter_side to internal values |
|
| 252 | 50x |
jitter_side_internal <- switch(jitter_side, |
| 253 | 50x |
"first" = "group1", |
| 254 | 50x |
"second" = "group2", |
| 255 | 50x |
"left" = "group1", |
| 256 | 50x |
"right" = "group2", |
| 257 | 50x |
jitter_side |
| 258 |
) |
|
| 259 | ||
| 260 | 50x |
if (orientation == "vertical") {
|
| 261 |
# VERTICAL: Two vertical columns side by side |
|
| 262 |
# group1 on left, group2 on right, nodes stacked vertically within each |
|
| 263 | 38x |
x_pos[lhs_idx] <- group1_pos |
| 264 | 38x |
x_pos[rhs_idx] <- group2_pos |
| 265 | ||
| 266 |
# Spread nodes vertically within each column |
|
| 267 | 38x |
if (n_g1 > 1) {
|
| 268 | 36x |
y_pos[lhs_idx] <- seq(1, -1, length.out = n_g1) |
| 269 | 2x |
} else if (n_g1 == 1) {
|
| 270 | 2x |
y_pos[lhs_idx] <- 0 |
| 271 |
} |
|
| 272 | 38x |
if (n_g2 > 1) {
|
| 273 | 34x |
y_pos[rhs_idx] <- seq(1, -1, length.out = n_g2) |
| 274 | 4x |
} else if (n_g2 == 1) {
|
| 275 | 4x |
y_pos[rhs_idx] <- 0 |
| 276 |
} |
|
| 277 | ||
| 278 |
# Apply jitter (horizontal direction - toward center) |
|
| 279 | 38x |
if (isTRUE(jitter) && jitter_side != "none") {
|
| 280 | 32x |
x_jitter <- compute_connectivity_jitter_horizontal(weights, lhs_idx, rhs_idx, jitter_amount, jitter_side_internal) |
| 281 | 32x |
x_pos <- x_pos + x_jitter |
| 282 | 6x |
} else if (is.numeric(jitter) && length(jitter) == 1 && jitter > 0 && jitter_side != "none") {
|
| 283 | 2x |
x_jitter <- compute_connectivity_jitter_horizontal(weights, lhs_idx, rhs_idx, jitter, jitter_side_internal) |
| 284 | 2x |
x_pos <- x_pos + x_jitter |
| 285 | 4x |
} else if (is.list(jitter)) {
|
| 286 | 1x |
for (label_name in names(jitter)) {
|
| 287 | 2x |
idx <- match(label_name, lab) |
| 288 | 2x |
if (!is.na(idx)) {
|
| 289 | 2x |
x_pos[idx] <- x_pos[idx] + jitter[[label_name]] |
| 290 |
} |
|
| 291 |
} |
|
| 292 |
} |
|
| 293 | ||
| 294 |
# Weight-based reordering (if not using list order) |
|
| 295 | 38x |
if (!use_list_order) {
|
| 296 | 3x |
edges <- weights[lhs_idx, rhs_idx, drop = FALSE] |
| 297 | 3x |
out_str <- rowSums(edges, na.rm = TRUE) |
| 298 | 3x |
in_str <- colSums(edges, na.rm = TRUE) |
| 299 | ||
| 300 | 3x |
out_str[out_str == 0] <- 1e-10 |
| 301 | 3x |
in_str[in_str == 0] <- 1e-10 |
| 302 | ||
| 303 | 3x |
rank_in <- rank(-in_str, ties.method = "first") |
| 304 | 3x |
rank_out <- rank(-out_str, ties.method = "first") |
| 305 | ||
| 306 | 3x |
pos_g1 <- rowSums(edges * rank_in[col(edges)], na.rm = TRUE) / out_str |
| 307 | 3x |
pos_g2 <- colSums(edges * rank_out, na.rm = TRUE) / in_str |
| 308 | ||
| 309 | 3x |
g1_order <- rank(pos_g1, ties.method = "first") |
| 310 | 3x |
g2_order <- rank(pos_g2, ties.method = "first") |
| 311 | ||
| 312 | 3x |
y_g1_sorted <- sort(y_pos[lhs_idx], decreasing = TRUE) |
| 313 | 3x |
y_g2_sorted <- sort(y_pos[rhs_idx], decreasing = TRUE) |
| 314 | ||
| 315 | 3x |
y_pos[lhs_idx] <- y_g1_sorted[g1_order] |
| 316 | 3x |
y_pos[rhs_idx] <- y_g2_sorted[g2_order] |
| 317 |
} |
|
| 318 | ||
| 319 |
} else {
|
|
| 320 |
# HORIZONTAL: Two horizontal rows stacked top/bottom |
|
| 321 |
# group1 on top, group2 on bottom, nodes spread horizontally within each |
|
| 322 | 12x |
y_pos[lhs_idx] <- group1_pos |
| 323 | 12x |
y_pos[rhs_idx] <- group2_pos |
| 324 | ||
| 325 |
# Spread nodes horizontally within each row |
|
| 326 | 12x |
if (n_g1 > 1) {
|
| 327 | 10x |
x_pos[lhs_idx] <- seq(-1, 1, length.out = n_g1) |
| 328 | 2x |
} else if (n_g1 == 1) {
|
| 329 | 2x |
x_pos[lhs_idx] <- 0 |
| 330 |
} |
|
| 331 | 12x |
if (n_g2 > 1) {
|
| 332 | 11x |
x_pos[rhs_idx] <- seq(-1, 1, length.out = n_g2) |
| 333 | 1x |
} else if (n_g2 == 1) {
|
| 334 | 1x |
x_pos[rhs_idx] <- 0 |
| 335 |
} |
|
| 336 | ||
| 337 |
# Apply jitter (vertical direction - toward center) |
|
| 338 | 12x |
if (isTRUE(jitter) && jitter_side != "none") {
|
| 339 | 8x |
y_jitter <- compute_connectivity_jitter_vertical(weights, lhs_idx, rhs_idx, jitter_amount, jitter_side_internal) |
| 340 | 8x |
y_pos <- y_pos + y_jitter |
| 341 | 4x |
} else if (is.numeric(jitter) && length(jitter) == 1 && jitter > 0 && jitter_side != "none") {
|
| 342 | 2x |
y_jitter <- compute_connectivity_jitter_vertical(weights, lhs_idx, rhs_idx, jitter, jitter_side_internal) |
| 343 | 2x |
y_pos <- y_pos + y_jitter |
| 344 | 2x |
} else if (is.list(jitter)) {
|
| 345 | 2x |
for (label_name in names(jitter)) {
|
| 346 | 4x |
idx <- match(label_name, lab) |
| 347 | 4x |
if (!is.na(idx)) {
|
| 348 | 4x |
y_pos[idx] <- y_pos[idx] + jitter[[label_name]] |
| 349 |
} |
|
| 350 |
} |
|
| 351 |
} |
|
| 352 |
} |
|
| 353 | 30x |
} else if (layout == "polygon") {
|
| 354 |
# Polygon layout: n groups along edges of a regular n-sided polygon |
|
| 355 | 21x |
pos <- compute_polygon_layout(node_list, lab, group_indices, n_groups, angle_spacing) |
| 356 | 21x |
x_pos <- pos$x |
| 357 | 21x |
y_pos <- pos$y |
| 358 | 9x |
} else if (layout == "circular") {
|
| 359 |
# Circular layout: n groups along arcs of a circle |
|
| 360 | 9x |
pos <- compute_circular_layout(node_list, lab, group_indices, n_groups, angle_spacing) |
| 361 | 9x |
x_pos <- pos$x |
| 362 | 9x |
y_pos <- pos$y |
| 363 |
} |
|
| 364 | ||
| 365 | 80x |
layout_mat <- cbind(x = x_pos, y = y_pos) |
| 366 | ||
| 367 |
# Compute edge colors based on source group |
|
| 368 |
# Create a mapping from node index to group index |
|
| 369 | 80x |
node_to_group <- rep(NA, n) |
| 370 | 80x |
for (i in seq_along(node_list)) {
|
| 371 | 196x |
node_to_group[group_indices[[i]]] <- i |
| 372 |
} |
|
| 373 | ||
| 374 |
# Determine edge colors |
|
| 375 | 80x |
if (is.null(edge_colors)) {
|
| 376 |
# Use darker/more saturated versions of group colors for edges |
|
| 377 | 76x |
edge_color_palette <- c("#e6a500", "#7a5a7a", "#4a90b8", "#5cb85c",
|
| 378 | 76x |
"#d9534f", "#5bc0de", "#9b59b6", "#8bc34a", |
| 379 | 76x |
"#ff7043", "#78909c", "#ab47bc", "#aed581") |
| 380 | 76x |
edge_colors <- rep_len(edge_color_palette, n_groups) |
| 381 | 4x |
} else if (isFALSE(edge_colors)) {
|
| 382 | 3x |
edge_colors <- NULL |
| 383 |
} |
|
| 384 | ||
| 385 |
# Build edge color matrix if edge_colors is specified |
|
| 386 | 80x |
edge_color_matrix <- NULL |
| 387 | 80x |
if (!is.null(edge_colors)) {
|
| 388 | 77x |
edge_color_matrix <- matrix(NA, nrow = n, ncol = n) |
| 389 | 77x |
for (i in seq_len(n)) {
|
| 390 | 473x |
src_group <- node_to_group[i] |
| 391 | 473x |
if (!is.na(src_group)) {
|
| 392 | 473x |
edge_color_matrix[i, ] <- edge_colors[src_group] |
| 393 |
} |
|
| 394 |
} |
|
| 395 |
} |
|
| 396 | ||
| 397 |
# Call tplot |
|
| 398 |
# Capture ... args and remove edge.color if we're setting it |
|
| 399 | 80x |
dots <- list(...) |
| 400 | 80x |
if (!is.null(edge_color_matrix)) {
|
| 401 | 77x |
dots$edge.color <- NULL |
| 402 | 77x |
dots$`edge.color` <- NULL |
| 403 |
} |
|
| 404 | ||
| 405 | 80x |
tplot_args <- c( |
| 406 | 80x |
list( |
| 407 | 80x |
x = x, |
| 408 | 80x |
layout = layout_mat, |
| 409 | 80x |
color = colors, |
| 410 | 80x |
node_shape = shapes, |
| 411 | 80x |
curvature = curvature |
| 412 |
), |
|
| 413 | 80x |
dots |
| 414 |
) |
|
| 415 | ||
| 416 |
# Add edge colors if specified (tplot uses edge.color parameter) |
|
| 417 | 80x |
if (!is.null(edge_color_matrix)) {
|
| 418 | 77x |
tplot_args$edge.color <- edge_color_matrix |
| 419 |
} |
|
| 420 | ||
| 421 | 80x |
result <- do.call(tplot, tplot_args) |
| 422 | ||
| 423 |
# Draw legend if requested |
|
| 424 | 80x |
if (isTRUE(legend) && n_groups >= 2) {
|
| 425 |
# Get group names |
|
| 426 | 78x |
group_names <- names(node_list) |
| 427 | 78x |
if (is.null(group_names)) {
|
| 428 | 2x |
group_names <- paste0("Group ", seq_len(n_groups))
|
| 429 |
} |
|
| 430 | ||
| 431 |
# Map shape names to pch values |
|
| 432 | 78x |
shape_to_pch <- c( |
| 433 | 78x |
"circle" = 21, "square" = 22, "diamond" = 23, "triangle" = 24, |
| 434 | 78x |
"pentagon" = 21, "hexagon" = 21, "star" = 8, "cross" = 3 |
| 435 |
) |
|
| 436 | 78x |
pch_values <- sapply(group_shapes, function(s) {
|
| 437 | 1x |
if (s %in% names(shape_to_pch)) shape_to_pch[s] else 21 |
| 438 |
}) |
|
| 439 | ||
| 440 |
# Draw legend |
|
| 441 | 78x |
graphics::legend( |
| 442 | 78x |
legend_position, |
| 443 | 78x |
legend = group_names, |
| 444 | 78x |
pch = pch_values, |
| 445 | 78x |
pt.bg = group_colors, |
| 446 | 78x |
col = if (!is.null(edge_colors)) edge_colors else "black", |
| 447 | 78x |
pt.cex = 1.5 / size_scale, |
| 448 | 78x |
cex = 0.8 / size_scale, |
| 449 | 78x |
bty = "n", |
| 450 | 78x |
title = "Groups" |
| 451 |
) |
|
| 452 |
} |
|
| 453 | ||
| 454 |
# Draw extension lines if requested (bipartite only) |
|
| 455 | 80x |
if (!isFALSE(extend_lines) && layout == "bipartite") {
|
| 456 | 8x |
line_len <- if (isTRUE(extend_lines)) 0.1 else extend_lines |
| 457 | 8x |
lhs_idx <- group_indices[[1]] |
| 458 | 8x |
rhs_idx <- group_indices[[2]] |
| 459 | ||
| 460 | 8x |
if (orientation == "vertical") {
|
| 461 |
# Vertical columns: group1 on left extends right, group2 on right extends left |
|
| 462 | 5x |
for (i in lhs_idx) {
|
| 463 | 15x |
graphics::segments( |
| 464 | 15x |
x0 = x_pos[i], y0 = y_pos[i], |
| 465 | 15x |
x1 = x_pos[i] + line_len, y1 = y_pos[i], |
| 466 | 15x |
col = colors[i], lwd = 1 / size_scale |
| 467 |
) |
|
| 468 |
} |
|
| 469 | 5x |
for (i in rhs_idx) {
|
| 470 | 15x |
graphics::segments( |
| 471 | 15x |
x0 = x_pos[i], y0 = y_pos[i], |
| 472 | 15x |
x1 = x_pos[i] - line_len, y1 = y_pos[i], |
| 473 | 15x |
col = colors[i], lwd = 1 / size_scale |
| 474 |
) |
|
| 475 |
} |
|
| 476 |
} else {
|
|
| 477 |
# Horizontal rows: group1 on top extends down, group2 on bottom extends up |
|
| 478 | 3x |
for (i in lhs_idx) {
|
| 479 | 9x |
graphics::segments( |
| 480 | 9x |
x0 = x_pos[i], y0 = y_pos[i], |
| 481 | 9x |
x1 = x_pos[i], y1 = y_pos[i] - line_len, |
| 482 | 9x |
col = colors[i], lwd = 1 / size_scale |
| 483 |
) |
|
| 484 |
} |
|
| 485 | 3x |
for (i in rhs_idx) {
|
| 486 | 9x |
graphics::segments( |
| 487 | 9x |
x0 = x_pos[i], y0 = y_pos[i], |
| 488 | 9x |
x1 = x_pos[i], y1 = y_pos[i] + line_len, |
| 489 | 9x |
col = colors[i], lwd = 1 / size_scale |
| 490 |
) |
|
| 491 |
} |
|
| 492 |
} |
|
| 493 |
} |
|
| 494 | ||
| 495 | 80x |
invisible(result) |
| 496 |
} |
|
| 497 | ||
| 498 |
#' Compute Connectivity-Based Jitter (Horizontal Layout) |
|
| 499 |
#' |
|
| 500 |
#' For horizontal layouts (left/right columns). Nodes with more cross-group |
|
| 501 |
#' connections are jittered horizontally toward center. |
|
| 502 |
#' |
|
| 503 |
#' @param weights Weight matrix. |
|
| 504 |
#' @param g1_idx Indices of group 1 nodes. |
|
| 505 |
#' @param g2_idx Indices of group 2 nodes. |
|
| 506 |
#' @param amount Maximum jitter amount. Default 0.8. |
|
| 507 |
#' @param side Which group(s) to jitter: "group1", "group2", or "both". |
|
| 508 |
#' |
|
| 509 |
#' @return Numeric vector of x-offsets for each node. |
|
| 510 |
#' |
|
| 511 |
#' @keywords internal |
|
| 512 |
compute_connectivity_jitter_horizontal <- function(weights, g1_idx, g2_idx, amount = 0.8, side = "group1") {
|
|
| 513 | 37x |
n <- nrow(weights) |
| 514 | 37x |
jitter <- rep(0, n) |
| 515 | ||
| 516 |
# Extract cross-group edges |
|
| 517 | 37x |
cross_weights <- weights[g1_idx, g2_idx, drop = FALSE] |
| 518 | ||
| 519 |
# Compute edge strength for each node |
|
| 520 | 37x |
g1_strength <- rowSums(abs(cross_weights), na.rm = TRUE) |
| 521 | 37x |
g2_strength <- colSums(abs(cross_weights), na.rm = TRUE) |
| 522 | ||
| 523 |
# Normalize to 0-1 range |
|
| 524 | 37x |
g1_max <- max(g1_strength, na.rm = TRUE) |
| 525 | 37x |
g2_max <- max(g2_strength, na.rm = TRUE) |
| 526 | ||
| 527 | 37x |
g1_norm <- if (g1_max > 0) g1_strength / g1_max else rep(0, length(g1_idx)) |
| 528 | 37x |
g2_norm <- if (g2_max > 0) g2_strength / g2_max else rep(0, length(g2_idx)) |
| 529 | ||
| 530 |
# High connectivity = jitter toward center |
|
| 531 |
# Group1 (left, positive x): negative jitter moves toward center |
|
| 532 |
# Group2 (right, negative x): positive jitter moves toward center |
|
| 533 | 37x |
if (side %in% c("group1", "both", "first")) {
|
| 534 | 36x |
jitter[g1_idx] <- -g1_norm * amount |
| 535 |
} |
|
| 536 | 37x |
if (side %in% c("group2", "both", "second")) {
|
| 537 | 4x |
jitter[g2_idx] <- g2_norm * amount |
| 538 |
} |
|
| 539 | ||
| 540 | 37x |
jitter |
| 541 |
} |
|
| 542 | ||
| 543 |
#' Compute Connectivity-Based Jitter (Vertical Layout) |
|
| 544 |
#' |
|
| 545 |
#' For vertical layouts (top/bottom rows). Nodes with more cross-group |
|
| 546 |
#' connections are jittered vertically toward center. |
|
| 547 |
#' |
|
| 548 |
#' @param weights Weight matrix. |
|
| 549 |
#' @param g1_idx Indices of group 1 nodes (top). |
|
| 550 |
#' @param g2_idx Indices of group 2 nodes (bottom). |
|
| 551 |
#' @param amount Maximum jitter amount. Default 0.8. |
|
| 552 |
#' @param side Which group(s) to jitter: "group1", "group2", or "both". |
|
| 553 |
#' |
|
| 554 |
#' @return Numeric vector of y-offsets for each node. |
|
| 555 |
#' |
|
| 556 |
#' @keywords internal |
|
| 557 |
compute_connectivity_jitter_vertical <- function(weights, g1_idx, g2_idx, amount = 0.8, side = "group1") {
|
|
| 558 | 12x |
n <- nrow(weights) |
| 559 | 12x |
jitter <- rep(0, n) |
| 560 | ||
| 561 |
# Extract cross-group edges |
|
| 562 | 12x |
cross_weights <- weights[g1_idx, g2_idx, drop = FALSE] |
| 563 | ||
| 564 |
# Compute edge strength for each node |
|
| 565 | 12x |
g1_strength <- rowSums(abs(cross_weights), na.rm = TRUE) |
| 566 | 12x |
g2_strength <- colSums(abs(cross_weights), na.rm = TRUE) |
| 567 | ||
| 568 |
# Normalize to 0-1 range |
|
| 569 | 12x |
g1_max <- max(g1_strength, na.rm = TRUE) |
| 570 | 12x |
g2_max <- max(g2_strength, na.rm = TRUE) |
| 571 | ||
| 572 | 12x |
g1_norm <- if (g1_max > 0) g1_strength / g1_max else rep(0, length(g1_idx)) |
| 573 | 12x |
g2_norm <- if (g2_max > 0) g2_strength / g2_max else rep(0, length(g2_idx)) |
| 574 | ||
| 575 |
# High connectivity = jitter toward center |
|
| 576 |
# Group1 (top, positive y): negative jitter moves toward center |
|
| 577 |
# Group2 (bottom, negative y): positive jitter moves toward center |
|
| 578 | 12x |
if (side %in% c("group1", "both", "first")) {
|
| 579 | 12x |
jitter[g1_idx] <- -g1_norm * amount |
| 580 |
} |
|
| 581 | 12x |
if (side %in% c("group2", "both", "second")) {
|
| 582 | 3x |
jitter[g2_idx] <- g2_norm * amount |
| 583 |
} |
|
| 584 | ||
| 585 | 12x |
jitter |
| 586 |
} |
|
| 587 | ||
| 588 |
#' Compute Polygon Layout |
|
| 589 |
#' |
|
| 590 |
#' Positions nodes along edges of a regular n-sided polygon. |
|
| 591 |
#' Each group is placed along one edge. Edges are offset outward from vertices |
|
| 592 |
#' to create empty angles at corners. |
|
| 593 |
#' |
|
| 594 |
#' @param node_list List of n character vectors. |
|
| 595 |
#' @param lab Node labels from model. |
|
| 596 |
#' @param group_indices List of index vectors for each group. |
|
| 597 |
#' @param n_sides Number of sides (groups). |
|
| 598 |
#' @param angle_spacing How far to push edges away from vertices (0-1). Default 0.15. |
|
| 599 |
#' |
|
| 600 |
#' @return List with x and y position vectors. |
|
| 601 |
#' |
|
| 602 |
#' @keywords internal |
|
| 603 |
compute_polygon_layout <- function(node_list, lab, group_indices, n_sides, angle_spacing = 0.15) {
|
|
| 604 | 23x |
n <- length(lab) |
| 605 | 23x |
x_pos <- rep(0, n) |
| 606 | 23x |
y_pos <- rep(0, n) |
| 607 | ||
| 608 |
# Radius of the polygon |
|
| 609 | ||
| 610 | 23x |
radius <- 1.2 |
| 611 | ||
| 612 |
# Compute vertices of regular polygon |
|
| 613 |
# Start from top (pi/2) and go clockwise |
|
| 614 | 23x |
angles <- pi/2 - (0:n_sides) * 2 * pi / n_sides |
| 615 | 23x |
vertices_x <- radius * cos(angles) |
| 616 | 23x |
vertices_y <- radius * sin(angles) |
| 617 | ||
| 618 |
# Edge push distance (outward from center) |
|
| 619 | 23x |
edge_push <- 0.15 |
| 620 | ||
| 621 |
# Place each group along its edge |
|
| 622 | ||
| 623 | 23x |
for (i in seq_len(n_sides)) {
|
| 624 | 78x |
g_idx <- group_indices[[i]] |
| 625 | 78x |
n_nodes <- length(g_idx) |
| 626 | ||
| 627 |
# Edge from vertex i to vertex i+1 |
|
| 628 | 78x |
v1 <- c(vertices_x[i], vertices_y[i]) |
| 629 | 78x |
v2 <- c(vertices_x[i + 1], vertices_y[i + 1]) |
| 630 | ||
| 631 |
# Edge midpoint |
|
| 632 | 78x |
mid <- (v1 + v2) / 2 |
| 633 | ||
| 634 |
# Outward direction (perpendicular to edge, pointing away from center) |
|
| 635 | 78x |
edge_vec <- v2 - v1 |
| 636 | 78x |
outward <- c(-edge_vec[2], edge_vec[1]) # Perpendicular |
| 637 | 78x |
outward <- outward / sqrt(sum(outward^2)) # Normalize |
| 638 | ||
| 639 |
# Make sure it points outward (away from origin) |
|
| 640 | 78x |
if (sum(outward * mid) < 0) {
|
| 641 | ! |
outward <- -outward |
| 642 |
} |
|
| 643 | ||
| 644 | 78x |
if (n_nodes > 1) {
|
| 645 |
# Distribute nodes along edge with gaps at corners |
|
| 646 | 52x |
t_vals <- seq(angle_spacing, 1 - angle_spacing, length.out = n_nodes) |
| 647 | 52x |
base_x <- v1[1] + t_vals * (v2[1] - v1[1]) |
| 648 | 52x |
base_y <- v1[2] + t_vals * (v2[2] - v1[2]) |
| 649 | ||
| 650 |
# Push outward |
|
| 651 | 52x |
x_pos[g_idx] <- base_x + outward[1] * edge_push |
| 652 | 52x |
y_pos[g_idx] <- base_y + outward[2] * edge_push |
| 653 | 26x |
} else if (n_nodes == 1) {
|
| 654 |
# Single node at midpoint, pushed outward |
|
| 655 | 26x |
x_pos[g_idx] <- mid[1] + outward[1] * edge_push |
| 656 | 26x |
y_pos[g_idx] <- mid[2] + outward[2] * edge_push |
| 657 |
} |
|
| 658 |
} |
|
| 659 | ||
| 660 | 23x |
list(x = x_pos, y = y_pos) |
| 661 |
} |
|
| 662 | ||
| 663 |
#' Compute Circular Layout |
|
| 664 |
#' |
|
| 665 |
#' Positions nodes along arcs of a circle, with each group occupying one arc. |
|
| 666 |
#' Groups are separated by gaps controlled by angle_spacing. |
|
| 667 |
#' |
|
| 668 |
#' @param node_list List of n character vectors. |
|
| 669 |
#' @param lab Node labels from model. |
|
| 670 |
#' @param group_indices List of index vectors for each group. |
|
| 671 |
#' @param n_groups Number of groups. |
|
| 672 |
#' @param angle_spacing Gap between groups as fraction of arc (0-1). Default 0.15. |
|
| 673 |
#' |
|
| 674 |
#' @return List with x and y position vectors. |
|
| 675 |
#' |
|
| 676 |
#' @keywords internal |
|
| 677 |
compute_circular_layout <- function(node_list, lab, group_indices, n_groups, angle_spacing = 0.15) {
|
|
| 678 | 10x |
n <- length(lab) |
| 679 | 10x |
x_pos <- rep(0, n) |
| 680 | 10x |
y_pos <- rep(0, n) |
| 681 | ||
| 682 |
# Radius of the circle |
|
| 683 | 10x |
radius <- 1.2 |
| 684 | ||
| 685 |
# Total angle per group (including gap) |
|
| 686 | 10x |
angle_per_group <- 2 * pi / n_groups |
| 687 | ||
| 688 |
# Gap angle between groups |
|
| 689 | 10x |
gap_angle <- angle_per_group * angle_spacing |
| 690 | ||
| 691 |
# Usable arc angle per group |
|
| 692 | 10x |
arc_angle <- angle_per_group - gap_angle |
| 693 | ||
| 694 |
# Place each group along its arc |
|
| 695 | 10x |
for (i in seq_len(n_groups)) {
|
| 696 | 27x |
g_idx <- group_indices[[i]] |
| 697 | 27x |
n_nodes <- length(g_idx) |
| 698 | ||
| 699 |
# Start angle for this group (starting from top, going clockwise) |
|
| 700 |
# Add half gap at start |
|
| 701 | 27x |
start_angle <- pi/2 - (i - 1) * angle_per_group - gap_angle/2 |
| 702 | 27x |
end_angle <- start_angle - arc_angle |
| 703 | ||
| 704 | 27x |
if (n_nodes > 1) {
|
| 705 |
# Distribute nodes along arc |
|
| 706 | 24x |
angles <- seq(start_angle, end_angle, length.out = n_nodes) |
| 707 | 24x |
x_pos[g_idx] <- radius * cos(angles) |
| 708 | 24x |
y_pos[g_idx] <- radius * sin(angles) |
| 709 | 3x |
} else if (n_nodes == 1) {
|
| 710 |
# Single node at arc midpoint |
|
| 711 | 3x |
mid_angle <- (start_angle + end_angle) / 2 |
| 712 | 3x |
x_pos[g_idx] <- radius * cos(mid_angle) |
| 713 | 3x |
y_pos[g_idx] <- radius * sin(mid_angle) |
| 714 |
} |
|
| 715 |
} |
|
| 716 | ||
| 717 | 10x |
list(x = x_pos, y = y_pos) |
| 718 |
} |
| 1 |
#' @title igraph Input Parsing |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing igraph objects. |
|
| 4 |
#' @name input-igraph |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse igraph Object |
|
| 8 |
#' |
|
| 9 |
#' Convert an igraph object to internal network format. |
|
| 10 |
#' |
|
| 11 |
#' @param g An igraph object. |
|
| 12 |
#' @param directed Logical. Force directed interpretation. NULL uses igraph's setting. |
|
| 13 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 14 |
#' @noRd |
|
| 15 |
parse_igraph <- function(g, directed = NULL) {
|
|
| 16 |
# Check if igraph is available |
|
| 17 | 18x |
if (!has_package("igraph")) {
|
| 18 | 1x |
stop("Package 'igraph' is required for igraph input. ",
|
| 19 | 1x |
"Please install it with: install.packages('igraph')",
|
| 20 | 1x |
call. = FALSE) |
| 21 |
} |
|
| 22 | ||
| 23 |
# Validate input |
|
| 24 | 17x |
if (!inherits(g, "igraph")) {
|
| 25 | 2x |
stop("Input must be an igraph object", call. = FALSE)
|
| 26 |
} |
|
| 27 | ||
| 28 |
# Get directedness |
|
| 29 | 15x |
if (is.null(directed)) {
|
| 30 | 15x |
directed <- igraph::is_directed(g) |
| 31 |
} |
|
| 32 | ||
| 33 |
# Get number of nodes |
|
| 34 | 15x |
n <- igraph::vcount(g) |
| 35 | ||
| 36 |
# Get node labels |
|
| 37 | 15x |
labels <- igraph::V(g)$name |
| 38 | 15x |
if (is.null(labels) || all(is.na(labels))) {
|
| 39 | 12x |
labels <- as.character(seq_len(n)) |
| 40 |
} |
|
| 41 | ||
| 42 |
# Get edges |
|
| 43 | 15x |
edge_list <- igraph::as_edgelist(g, names = FALSE) |
| 44 | 15x |
from_idx <- edge_list[, 1] |
| 45 | 15x |
to_idx <- edge_list[, 2] |
| 46 | ||
| 47 |
# Get edge weights |
|
| 48 | 15x |
if ("weight" %in% igraph::edge_attr_names(g)) {
|
| 49 | 2x |
weight_vals <- igraph::E(g)$weight |
| 50 |
} else {
|
|
| 51 | 13x |
weight_vals <- rep(1, igraph::ecount(g)) |
| 52 |
} |
|
| 53 | ||
| 54 |
# Create data structures |
|
| 55 | 15x |
nodes <- create_nodes_df(n, labels) |
| 56 | 15x |
edges <- create_edges_df(from_idx, to_idx, weight_vals, directed) |
| 57 | ||
| 58 |
# Add any additional vertex attributes |
|
| 59 | 15x |
v_attrs <- igraph::vertex_attr_names(g) |
| 60 | 15x |
for (attr in v_attrs) {
|
| 61 | 4x |
if (attr != "name") {
|
| 62 | 1x |
nodes[[attr]] <- igraph::vertex_attr(g, attr) |
| 63 |
} |
|
| 64 |
} |
|
| 65 | ||
| 66 |
# Add any additional edge attributes |
|
| 67 | 15x |
e_attrs <- igraph::edge_attr_names(g) |
| 68 | 15x |
for (attr in e_attrs) {
|
| 69 | 3x |
if (attr != "weight") {
|
| 70 | 1x |
edges[[attr]] <- igraph::edge_attr(g, attr) |
| 71 |
} |
|
| 72 |
} |
|
| 73 | ||
| 74 | 15x |
list( |
| 75 | 15x |
nodes = nodes, |
| 76 | 15x |
edges = edges, |
| 77 | 15x |
directed = directed, |
| 78 | 15x |
weights = weight_vals |
| 79 |
) |
|
| 80 |
} |
|
| 81 | ||
| 82 |
#' Apply igraph Layout Function |
|
| 83 |
#' |
|
| 84 |
#' Apply an igraph layout function to a CographNetwork. |
|
| 85 |
#' |
|
| 86 |
#' @param network A CographNetwork object. |
|
| 87 |
#' @param layout_fn An igraph layout function (e.g., igraph::layout_nicely). |
|
| 88 |
#' @param ... Additional arguments passed to the layout function. |
|
| 89 |
#' @return Data frame with x, y coordinates. |
|
| 90 |
#' @noRd |
|
| 91 |
apply_igraph_layout <- function(network, layout_fn, ...) {
|
|
| 92 | 38x |
if (!has_package("igraph")) {
|
| 93 | 1x |
stop("Package 'igraph' is required for igraph layouts. ",
|
| 94 | 1x |
"Please install it with: install.packages('igraph')",
|
| 95 | 1x |
call. = FALSE) |
| 96 |
} |
|
| 97 | ||
| 98 |
# Convert network to igraph |
|
| 99 | 37x |
g <- network_to_igraph(network) |
| 100 | ||
| 101 |
# Apply layout function |
|
| 102 | 37x |
coords <- layout_fn(g, ...) |
| 103 | ||
| 104 |
# Normalize to 0.1-0.9 range |
|
| 105 | 37x |
coords <- normalize_coords(coords) |
| 106 | ||
| 107 | 37x |
data.frame(x = coords[, 1], y = coords[, 2]) |
| 108 |
} |
|
| 109 | ||
| 110 |
#' Apply igraph Layout by Name |
|
| 111 |
#' |
|
| 112 |
#' Apply an igraph layout by its name string. |
|
| 113 |
#' |
|
| 114 |
#' @param network A CographNetwork object. |
|
| 115 |
#' @param layout_name Layout name (e.g., "layout_nicely", "kk", "fr"). |
|
| 116 |
#' @param seed Random seed for deterministic layouts. Default 42. |
|
| 117 |
#' @param ... Additional arguments passed to the layout function. |
|
| 118 |
#' @return Data frame with x, y coordinates. |
|
| 119 |
#' @noRd |
|
| 120 |
apply_igraph_layout_by_name <- function(network, layout_name, seed = 42, ...) {
|
|
| 121 | 30x |
if (!has_package("igraph")) {
|
| 122 | 1x |
stop("Package 'igraph' is required for igraph layouts. ",
|
| 123 | 1x |
"Please install it with: install.packages('igraph')",
|
| 124 | 1x |
call. = FALSE) |
| 125 |
} |
|
| 126 | ||
| 127 |
# Map common names to igraph functions |
|
| 128 | 29x |
layout_map <- list( |
| 129 |
# Two-letter aliases (primary) |
|
| 130 | 29x |
"kk" = igraph::layout_with_kk, |
| 131 | 29x |
"fr" = igraph::layout_with_fr, |
| 132 | 29x |
"drl" = igraph::layout_with_drl, |
| 133 | 29x |
"lgl" = igraph::layout_with_lgl, |
| 134 | 29x |
"mds" = igraph::layout_with_mds, |
| 135 | 29x |
"go" = igraph::layout_with_graphopt, |
| 136 | 29x |
"tr" = igraph::layout_as_tree, |
| 137 | 29x |
"st" = igraph::layout_as_star, |
| 138 | 29x |
"gr" = igraph::layout_on_grid, |
| 139 | 29x |
"rd" = igraph::layout_randomly, |
| 140 | 29x |
"sp" = igraph::layout_on_sphere, |
| 141 | 29x |
"ni" = igraph::layout_nicely, |
| 142 | 29x |
"ci" = igraph::layout_in_circle, |
| 143 |
# Full names |
|
| 144 | 29x |
"layout_nicely" = igraph::layout_nicely, |
| 145 | 29x |
"layout_with_fr" = igraph::layout_with_fr, |
| 146 | 29x |
"layout_with_kk" = igraph::layout_with_kk, |
| 147 | 29x |
"layout_with_drl" = igraph::layout_with_drl, |
| 148 | 29x |
"layout_with_lgl" = igraph::layout_with_lgl, |
| 149 | 29x |
"layout_with_mds" = igraph::layout_with_mds, |
| 150 | 29x |
"layout_with_graphopt" = igraph::layout_with_graphopt, |
| 151 | 29x |
"layout_in_circle" = igraph::layout_in_circle, |
| 152 | 29x |
"layout_as_star" = igraph::layout_as_star, |
| 153 | 29x |
"layout_as_tree" = igraph::layout_as_tree, |
| 154 | 29x |
"layout_on_grid" = igraph::layout_on_grid, |
| 155 | 29x |
"layout_randomly" = igraph::layout_randomly, |
| 156 | 29x |
"layout_on_sphere" = igraph::layout_on_sphere, |
| 157 |
# Short aliases with igraph_ prefix |
|
| 158 | 29x |
"igraph_nicely" = igraph::layout_nicely, |
| 159 | 29x |
"igraph_fr" = igraph::layout_with_fr, |
| 160 | 29x |
"igraph_kk" = igraph::layout_with_kk, |
| 161 | 29x |
"igraph_drl" = igraph::layout_with_drl, |
| 162 | 29x |
"igraph_lgl" = igraph::layout_with_lgl, |
| 163 | 29x |
"igraph_mds" = igraph::layout_with_mds, |
| 164 | 29x |
"igraph_graphopt" = igraph::layout_with_graphopt, |
| 165 | 29x |
"igraph_circle" = igraph::layout_in_circle, |
| 166 | 29x |
"igraph_star" = igraph::layout_as_star, |
| 167 | 29x |
"igraph_tree" = igraph::layout_as_tree, |
| 168 | 29x |
"igraph_grid" = igraph::layout_on_grid, |
| 169 | 29x |
"igraph_random" = igraph::layout_randomly, |
| 170 | 29x |
"igraph_sphere" = igraph::layout_on_sphere |
| 171 |
) |
|
| 172 | ||
| 173 | 29x |
layout_fn <- layout_map[[layout_name]] |
| 174 | 29x |
if (is.null(layout_fn)) {
|
| 175 | 3x |
available <- c("kk", "fr", "drl", "mds", "go", "tr", "st", "gr", "rd", "ni", "ci")
|
| 176 | 3x |
stop("Unknown igraph layout: ", layout_name,
|
| 177 | 3x |
"\nAvailable (2-letter): ", paste(available, collapse = ", "), call. = FALSE) |
| 178 |
} |
|
| 179 | ||
| 180 |
# Set seed for deterministic layouts |
|
| 181 | 26x |
if (!is.null(seed)) {
|
| 182 | 26x |
set.seed(seed) |
| 183 |
} |
|
| 184 | ||
| 185 | 26x |
apply_igraph_layout(network, layout_fn, ...) |
| 186 |
} |
|
| 187 | ||
| 188 |
#' Convert CographNetwork to igraph |
|
| 189 |
#' |
|
| 190 |
#' Convert a CographNetwork object to an igraph object for layout computation. |
|
| 191 |
#' |
|
| 192 |
#' @param network A CographNetwork object. |
|
| 193 |
#' @return An igraph object. |
|
| 194 |
#' @noRd |
|
| 195 |
network_to_igraph <- function(network) {
|
|
| 196 | 60x |
edges <- network$get_edges() |
| 197 | 60x |
n <- network$n_nodes |
| 198 | ||
| 199 | 60x |
if (is.null(edges) || nrow(edges) == 0) {
|
| 200 |
# Empty graph |
|
| 201 | 5x |
g <- igraph::make_empty_graph(n, directed = network$is_directed) |
| 202 |
} else {
|
|
| 203 |
# Create edge list |
|
| 204 | 55x |
edge_mat <- as.matrix(edges[, c("from", "to")])
|
| 205 | 55x |
g <- igraph::graph_from_edgelist(edge_mat, directed = network$is_directed) |
| 206 | ||
| 207 |
# Add weights if present |
|
| 208 | 55x |
if (!is.null(edges$weight)) {
|
| 209 | 55x |
igraph::E(g)$weight <- edges$weight |
| 210 |
} |
|
| 211 |
} |
|
| 212 | ||
| 213 |
# Add node labels |
|
| 214 | 60x |
nodes <- network$get_nodes() |
| 215 | 60x |
if (!is.null(nodes$label)) {
|
| 216 | 60x |
igraph::V(g)$name <- nodes$label |
| 217 |
} |
|
| 218 | ||
| 219 | 60x |
g |
| 220 |
} |
|
| 221 | ||
| 222 |
#' Normalize Coordinates |
|
| 223 |
#' |
|
| 224 |
#' Normalize layout coordinates to 0.1-0.9 range. |
|
| 225 |
#' |
|
| 226 |
#' @param coords Matrix of x, y coordinates. |
|
| 227 |
#' @return Normalized coordinate matrix. |
|
| 228 |
#' @noRd |
|
| 229 |
normalize_coords <- function(coords) {
|
|
| 230 |
# Handle single node case |
|
| 231 | 41x |
if (nrow(coords) == 1) {
|
| 232 | 2x |
return(matrix(c(0.5, 0.5), nrow = 1)) |
| 233 |
} |
|
| 234 | ||
| 235 |
# Normalize each dimension |
|
| 236 | 39x |
for (i in 1:2) {
|
| 237 | 78x |
rng <- range(coords[, i], na.rm = TRUE) |
| 238 | 78x |
if (diff(rng) > 0) {
|
| 239 | 75x |
coords[, i] <- 0.1 + 0.8 * (coords[, i] - rng[1]) / diff(rng) |
| 240 |
} else {
|
|
| 241 | 3x |
coords[, i] <- 0.5 |
| 242 |
} |
|
| 243 |
} |
|
| 244 | ||
| 245 | 39x |
coords |
| 246 |
} |
| 1 |
#' @title Input Validation Utilities |
|
| 2 |
#' @description Utility functions for validating inputs. |
|
| 3 |
#' @name utils-validation |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Validate Network Object |
|
| 8 |
#' |
|
| 9 |
#' @param x Object to validate. |
|
| 10 |
#' @param arg_name Argument name for error messages. |
|
| 11 |
#' @keywords internal |
|
| 12 |
validate_network <- function(x, arg_name = "network") {
|
|
| 13 | 3x |
if (!inherits(x, "CographNetwork") && !inherits(x, "cograph_network")) {
|
| 14 | 2x |
stop(arg_name, " must be a CographNetwork object", call. = FALSE) |
| 15 |
} |
|
| 16 | ||
| 17 |
# Extract R6 object if wrapped |
|
| 18 | 1x |
if (inherits(x, "cograph_network")) {
|
| 19 | 1x |
x <- x$network |
| 20 |
} |
|
| 21 | ||
| 22 | 1x |
x |
| 23 |
} |
|
| 24 | ||
| 25 |
#' Validate Color |
|
| 26 |
#' |
|
| 27 |
#' @param x Color to validate. |
|
| 28 |
#' @param arg_name Argument name for error messages. |
|
| 29 |
#' @keywords internal |
|
| 30 |
validate_color <- function(x, arg_name = "color") {
|
|
| 31 | 7x |
if (is.null(x) || is.na(x)) {
|
| 32 | 2x |
return(TRUE) |
| 33 |
} |
|
| 34 | ||
| 35 | 5x |
if (x == "transparent") {
|
| 36 | 1x |
return(TRUE) |
| 37 |
} |
|
| 38 | ||
| 39 |
# Try to convert to RGB |
|
| 40 | 4x |
tryCatch({
|
| 41 | 4x |
grDevices::col2rgb(x) |
| 42 | 3x |
TRUE |
| 43 | 4x |
}, error = function(e) {
|
| 44 | 1x |
stop(arg_name, " is not a valid color: ", x, call. = FALSE) |
| 45 |
}) |
|
| 46 |
} |
|
| 47 | ||
| 48 |
#' Validate Numeric Range |
|
| 49 |
#' |
|
| 50 |
#' @param x Value to validate. |
|
| 51 |
#' @param min Minimum allowed value. |
|
| 52 |
#' @param max Maximum allowed value. |
|
| 53 |
#' @param arg_name Argument name for error messages. |
|
| 54 |
#' @keywords internal |
|
| 55 |
validate_range <- function(x, min = -Inf, max = Inf, arg_name = "value") {
|
|
| 56 | 60x |
if (!is.numeric(x)) {
|
| 57 | 1x |
stop(arg_name, " must be numeric", call. = FALSE) |
| 58 |
} |
|
| 59 | ||
| 60 | 59x |
if (any(x < min, na.rm = TRUE)) {
|
| 61 | 7x |
stop(arg_name, " must be >= ", min, call. = FALSE) |
| 62 |
} |
|
| 63 | ||
| 64 | 52x |
if (any(x > max, na.rm = TRUE)) {
|
| 65 | 11x |
stop(arg_name, " must be <= ", max, call. = FALSE) |
| 66 |
} |
|
| 67 | ||
| 68 | 41x |
TRUE |
| 69 |
} |
|
| 70 | ||
| 71 |
#' Validate Choice |
|
| 72 |
#' |
|
| 73 |
#' @param x Value to validate. |
|
| 74 |
#' @param choices Allowed values. |
|
| 75 |
#' @param arg_name Argument name for error messages. |
|
| 76 |
#' @keywords internal |
|
| 77 |
validate_choice <- function(x, choices, arg_name = "value") {
|
|
| 78 | 3x |
if (!x %in% choices) {
|
| 79 | 1x |
stop(arg_name, " must be one of: ", paste(choices, collapse = ", "), |
| 80 | 1x |
call. = FALSE) |
| 81 |
} |
|
| 82 | 2x |
TRUE |
| 83 |
} |
|
| 84 | ||
| 85 |
#' Validate Length Match |
|
| 86 |
#' |
|
| 87 |
#' @param x Vector to validate. |
|
| 88 |
#' @param expected_length Expected length. |
|
| 89 |
#' @param arg_name Argument name for error messages. |
|
| 90 |
#' @param allow_single Allow single value (will be recycled). |
|
| 91 |
#' @keywords internal |
|
| 92 |
validate_length <- function(x, expected_length, arg_name = "value", |
|
| 93 |
allow_single = TRUE) {
|
|
| 94 | 4x |
if (length(x) == expected_length) {
|
| 95 | 2x |
return(TRUE) |
| 96 |
} |
|
| 97 | ||
| 98 | 2x |
if (allow_single && length(x) == 1) {
|
| 99 | 1x |
return(TRUE) |
| 100 |
} |
|
| 101 | ||
| 102 | 1x |
stop(arg_name, " must have length ", expected_length, |
| 103 | 1x |
if (allow_single) " or 1", call. = FALSE) |
| 104 |
} |
|
| 105 | ||
| 106 |
#' Recycle Value to Length |
|
| 107 |
#' |
|
| 108 |
#' @param x Value to recycle. |
|
| 109 |
#' @param n Target length. |
|
| 110 |
#' @return Recycled vector. |
|
| 111 |
#' @keywords internal |
|
| 112 |
recycle_to_length <- function(x, n) {
|
|
| 113 | 16056x |
if (length(x) == n) {
|
| 114 | 2058x |
return(x) |
| 115 |
} |
|
| 116 | ||
| 117 | 13998x |
if (length(x) == 1) {
|
| 118 | 13902x |
return(rep(x, n)) |
| 119 |
} |
|
| 120 | ||
| 121 |
# Recycle with warning if not evenly divisible |
|
| 122 | 96x |
rep_len(x, n) |
| 123 |
} |
|
| 124 | ||
| 125 |
#' Expand Parameter to Length (Strict) |
|
| 126 |
#' |
|
| 127 |
#' Expands a parameter to length n. Only accepts length 1 or length n. |
|
| 128 |
#' Throws error for any other length (no silent recycling). |
|
| 129 |
#' |
|
| 130 |
#' @param x Value to expand. |
|
| 131 |
#' @param n Target length. |
|
| 132 |
#' @param name Parameter name for error message. |
|
| 133 |
#' @return Vector of length n. |
|
| 134 |
#' @keywords internal |
|
| 135 |
expand_param <- function(x, n, name = "parameter") {
|
|
| 136 | 21772x |
if (length(x) == 1) {
|
| 137 | 20598x |
return(rep(x, n)) |
| 138 |
} |
|
| 139 | 1174x |
if (length(x) == n) {
|
| 140 | 1173x |
return(x) |
| 141 |
} |
|
| 142 | 1x |
stop(name, " must be length 1 or ", n, ", not ", length(x), call. = FALSE) |
| 143 |
} |
|
| 144 | ||
| 145 |
#' Resolve Aesthetic Value |
|
| 146 |
#' |
|
| 147 |
#' Resolve an aesthetic value that could be a constant, vector, or column name. |
|
| 148 |
#' |
|
| 149 |
#' @param value Value to resolve. |
|
| 150 |
#' @param data Data frame to look up column names. |
|
| 151 |
#' @param n Expected length. |
|
| 152 |
#' @param default Default value if NULL. |
|
| 153 |
#' @return Resolved vector of values. |
|
| 154 |
#' @keywords internal |
|
| 155 |
resolve_aesthetic <- function(value, data = NULL, n = NULL, default = NULL) {
|
|
| 156 | 914x |
if (is.null(value)) {
|
| 157 | 2x |
if (is.null(default)) {
|
| 158 | 1x |
return(NULL) |
| 159 |
} |
|
| 160 | 1x |
value <- default |
| 161 |
} |
|
| 162 | ||
| 163 |
# If it's a single string and could be a column name |
|
| 164 | 913x |
if (is.character(value) && length(value) == 1 && !is.null(data)) {
|
| 165 | 237x |
if (value %in% names(data)) {
|
| 166 | 1x |
return(data[[value]]) |
| 167 |
} |
|
| 168 |
} |
|
| 169 | ||
| 170 |
# Recycle to length |
|
| 171 | 912x |
if (!is.null(n)) {
|
| 172 | 910x |
value <- recycle_to_length(value, n) |
| 173 |
} |
|
| 174 | ||
| 175 | 912x |
value |
| 176 |
} |
| 1 |
#' @title Node Aesthetics |
|
| 2 |
#' @description Functions for setting node aesthetic properties. |
|
| 3 |
#' @name aes-nodes |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Set Node Aesthetics |
|
| 7 |
#' |
|
| 8 |
#' Customize the visual appearance of nodes in a network plot. |
|
| 9 |
#' |
|
| 10 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 11 |
#' Matrices and other inputs are auto-converted. |
|
| 12 |
#' @param size Node size. Can be a single value, vector (per-node), or column name. |
|
| 13 |
#' @param shape Node shape. Options: "circle", "square", "triangle", "diamond", |
|
| 14 |
#' "pentagon", "hexagon", "ellipse", "heart", "star", "pie", "donut", "cross", "rectangle", |
|
| 15 |
#' or any custom SVG shape registered with register_svg_shape(). |
|
| 16 |
#' @param node_svg Custom SVG for node shape: path to SVG file OR inline SVG string. |
|
| 17 |
#' Overrides shape parameter when provided. |
|
| 18 |
#' @param svg_preserve_aspect Logical: maintain SVG aspect ratio? Default TRUE. |
|
| 19 |
#' @param fill Node fill color. Can be a single color, vector, or column name. |
|
| 20 |
#' @param border_color Node border color. |
|
| 21 |
#' @param border_width Node border width. |
|
| 22 |
#' @param alpha Node transparency (0-1). |
|
| 23 |
#' @param label_size Label text size. |
|
| 24 |
#' @param label_color Label text color. |
|
| 25 |
#' @param label_position Label position: "center", "above", "below", "left", "right". |
|
| 26 |
#' @param show_labels Logical. Show node labels? Default TRUE. |
|
| 27 |
#' @param pie_values For pie shape: list or matrix of values for pie segments. |
|
| 28 |
#' Each element corresponds to a node and contains values for its segments. |
|
| 29 |
#' @param pie_colors For pie shape: colors for pie segments. |
|
| 30 |
#' @param pie_border_width Border width for pie chart nodes. |
|
| 31 |
#' @param donut_fill For donut shape: numeric value (0-1) specifying fill proportion. |
|
| 32 |
#' 0.1 = 10% filled, 0.5 = 50% filled, 1.0 = fully filled ring. |
|
| 33 |
#' Can be a single value (all nodes) or vector (per-node values). |
|
| 34 |
#' @param donut_values Deprecated. Use donut_fill for simple fill proportion. |
|
| 35 |
#' Still works for backwards compatibility. |
|
| 36 |
#' @param donut_color For donut shape: fill color(s) for the donut ring. |
|
| 37 |
#' Single color sets fill for all nodes. |
|
| 38 |
#' Two colors set fill and background for all nodes. |
|
| 39 |
#' More than 2 colors set per-node fill colors (recycled to n_nodes). |
|
| 40 |
#' Default: "lightgray" fill, "gray90" background when shape="donut". |
|
| 41 |
#' @param donut_colors Deprecated. Use donut_color instead. |
|
| 42 |
#' @param donut_border_width Border width for donut chart nodes. |
|
| 43 |
#' @param donut_inner_ratio For donut shape: inner radius ratio (0-1). Default 0.5. |
|
| 44 |
#' @param donut_bg_color For donut shape: background color for unfilled portion. |
|
| 45 |
#' @param donut_shape For donut: base shape for ring ("circle", "square", "hexagon", "triangle", "diamond", "pentagon"). Default "circle".
|
|
| 46 |
#' @param donut_show_value For donut shape: show value in center? Default FALSE. |
|
| 47 |
#' @param donut_value_size For donut shape: font size for center value. |
|
| 48 |
#' @param donut_value_color For donut shape: color for center value text. |
|
| 49 |
#' @param donut_value_fontface For donut shape: font face for center value ("plain", "bold", "italic", "bold.italic"). Default "bold".
|
|
| 50 |
#' @param donut_value_fontfamily For donut shape: font family for center value ("sans", "serif", "mono"). Default "sans".
|
|
| 51 |
#' @param donut_value_digits For donut shape: decimal places for value display. Default 2. |
|
| 52 |
#' @param donut_value_prefix For donut shape: text before value (e.g., "$"). Default "". |
|
| 53 |
#' @param donut_value_suffix For donut shape: text after value (e.g., "%"). Default "". |
|
| 54 |
#' @param donut_value_format For donut shape: custom format function (overrides digits). |
|
| 55 |
#' @param donut2_values For double donut: list of values for inner donut ring. |
|
| 56 |
#' @param donut2_colors For double donut: colors for inner donut ring segments. |
|
| 57 |
#' @param donut2_inner_ratio For double donut: inner radius ratio for inner donut ring. Default 0.4. |
|
| 58 |
#' @param label_fontface Font face for node labels: "plain", "bold", "italic", "bold.italic". Default "plain". |
|
| 59 |
#' @param label_fontfamily Font family for node labels: "sans", "serif", "mono", or system font. Default "sans". |
|
| 60 |
#' @param label_hjust Horizontal justification for node labels (0=left, 0.5=center, 1=right). Default 0.5. |
|
| 61 |
#' @param label_vjust Vertical justification for node labels (0=bottom, 0.5=center, 1=top). Default 0.5. |
|
| 62 |
#' @param label_angle Text rotation angle in degrees for node labels. Default 0. |
|
| 63 |
#' @param node_names Alternative names for legend (separate from display labels). |
|
| 64 |
#' |
|
| 65 |
#' @details |
|
| 66 |
#' ## Vectorization |
|
| 67 |
#' All aesthetic parameters can be specified as: |
|
| 68 |
#' \itemize{
|
|
| 69 |
#' \item \strong{Single value}: Applied to all nodes (e.g., \code{fill = "blue"})
|
|
| 70 |
#' \item \strong{Vector}: Per-node values, recycled if shorter than node count
|
|
| 71 |
#' \item \strong{Column name}: String referencing a column in the node data frame
|
|
| 72 |
#' } |
|
| 73 |
#' |
|
| 74 |
#' Parameters are validated for correct length; providing a vector with length |
|
| 75 |
#' other than 1 or n_nodes will produce a warning about recycling. |
|
| 76 |
#' |
|
| 77 |
#' ## Donut Charts |
|
| 78 |
#' Donut charts are ideal for showing a single proportion (0-1) per node: |
|
| 79 |
#' \itemize{
|
|
| 80 |
#' \item Set \code{donut_fill} to a numeric value or vector (0 = empty, 1 = full)
|
|
| 81 |
#' \item Use \code{donut_color} to set fill color(s)
|
|
| 82 |
#' \item Use \code{donut_shape} for non-circular donuts ("square", "hexagon", etc.)
|
|
| 83 |
#' \item Enable \code{donut_show_value = TRUE} to display the value in the center
|
|
| 84 |
#' } |
|
| 85 |
#' |
|
| 86 |
#' @return Modified cograph_network object that can be piped to further customization |
|
| 87 |
#' functions or plotting functions. |
|
| 88 |
#' |
|
| 89 |
#' @seealso |
|
| 90 |
#' \code{\link{sn_edges}} for edge customization,
|
|
| 91 |
#' \code{\link{cograph}} for network creation,
|
|
| 92 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting,
|
|
| 93 |
#' \code{\link{sn_layout}} for layout algorithms,
|
|
| 94 |
#' \code{\link{sn_theme}} for visual themes
|
|
| 95 |
#' |
|
| 96 |
#' @export |
|
| 97 |
#' |
|
| 98 |
#' @examples |
|
| 99 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 100 |
#' |
|
| 101 |
#' # Basic usage with cograph() |
|
| 102 |
#' cograph(adj) |> |
|
| 103 |
#' sn_nodes(size = 0.08, fill = "steelblue", shape = "circle") |
|
| 104 |
#' |
|
| 105 |
#' # Direct matrix input (auto-converted) |
|
| 106 |
#' adj |> sn_nodes(fill = "coral", size = 0.1) |
|
| 107 |
#' |
|
| 108 |
#' # Per-node customization with vectors |
|
| 109 |
#' cograph(adj) |> |
|
| 110 |
#' sn_nodes( |
|
| 111 |
#' size = c(0.08, 0.06, 0.1), |
|
| 112 |
#' fill = c("red", "blue", "green"),
|
|
| 113 |
#' label_position = c("above", "below", "center")
|
|
| 114 |
#' ) |> |
|
| 115 |
#' splot() |
|
| 116 |
#' |
|
| 117 |
#' # Donut chart nodes showing proportions |
|
| 118 |
#' cograph(adj) |> |
|
| 119 |
#' sn_nodes( |
|
| 120 |
#' donut_fill = c(0.25, 0.75, 0.5), |
|
| 121 |
#' donut_color = "steelblue", |
|
| 122 |
#' donut_show_value = TRUE, |
|
| 123 |
#' donut_value_suffix = "%" |
|
| 124 |
#' ) |> |
|
| 125 |
#' splot() |
|
| 126 |
#' |
|
| 127 |
#' # Mixed shapes per node |
|
| 128 |
#' cograph(adj) |> |
|
| 129 |
#' sn_nodes( |
|
| 130 |
#' shape = c("circle", "square", "triangle"),
|
|
| 131 |
#' fill = c("#E41A1C", "#377EB8", "#4DAF4A")
|
|
| 132 |
#' ) |> |
|
| 133 |
#' splot() |
|
| 134 |
sn_nodes <- function(network, |
|
| 135 |
size = NULL, |
|
| 136 |
shape = NULL, |
|
| 137 |
node_svg = NULL, |
|
| 138 |
svg_preserve_aspect = NULL, |
|
| 139 |
fill = NULL, |
|
| 140 |
border_color = NULL, |
|
| 141 |
border_width = NULL, |
|
| 142 |
alpha = NULL, |
|
| 143 |
label_size = NULL, |
|
| 144 |
label_color = NULL, |
|
| 145 |
label_position = NULL, |
|
| 146 |
show_labels = NULL, |
|
| 147 |
pie_values = NULL, |
|
| 148 |
pie_colors = NULL, |
|
| 149 |
pie_border_width = NULL, |
|
| 150 |
donut_fill = NULL, |
|
| 151 |
donut_values = NULL, |
|
| 152 |
donut_color = NULL, |
|
| 153 |
donut_colors = NULL, # Deprecated: use donut_color |
|
| 154 |
donut_border_width = NULL, |
|
| 155 |
donut_inner_ratio = NULL, |
|
| 156 |
donut_bg_color = NULL, |
|
| 157 |
donut_shape = NULL, |
|
| 158 |
donut_show_value = NULL, |
|
| 159 |
donut_value_size = NULL, |
|
| 160 |
donut_value_color = NULL, |
|
| 161 |
donut_value_fontface = NULL, |
|
| 162 |
donut_value_fontfamily = NULL, |
|
| 163 |
donut_value_digits = NULL, |
|
| 164 |
donut_value_prefix = NULL, |
|
| 165 |
donut_value_suffix = NULL, |
|
| 166 |
donut_value_format = NULL, |
|
| 167 |
donut2_values = NULL, |
|
| 168 |
donut2_colors = NULL, |
|
| 169 |
donut2_inner_ratio = NULL, |
|
| 170 |
label_fontface = NULL, |
|
| 171 |
label_fontfamily = NULL, |
|
| 172 |
label_hjust = NULL, |
|
| 173 |
label_vjust = NULL, |
|
| 174 |
label_angle = NULL, |
|
| 175 |
node_names = NULL) {
|
|
| 176 | ||
| 177 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 178 | 651x |
network <- ensure_cograph_network(network) |
| 179 | ||
| 180 |
# Clone the network to maintain immutability |
|
| 181 | 651x |
new_net <- network$network$clone_network() |
| 182 | ||
| 183 |
# Get node count for validation |
|
| 184 | 651x |
n <- new_net$n_nodes |
| 185 | 651x |
nodes_df <- new_net$get_nodes() |
| 186 | ||
| 187 |
# Build aesthetics list |
|
| 188 | 651x |
aes <- list() |
| 189 | ||
| 190 | 651x |
if (!is.null(size)) {
|
| 191 | 521x |
aes$size <- resolve_aesthetic(size, nodes_df, n) |
| 192 |
} |
|
| 193 | ||
| 194 | 651x |
if (!is.null(shape)) {
|
| 195 | 139x |
aes$shape <- resolve_aesthetic(shape, nodes_df, n) |
| 196 |
} |
|
| 197 | ||
| 198 | 651x |
if (!is.null(node_svg)) {
|
| 199 | 1x |
aes$node_svg <- node_svg |
| 200 |
# Register as temporary SVG shape if not already registered |
|
| 201 | 1x |
if (!is.null(node_svg) && is.character(node_svg)) {
|
| 202 | 1x |
temp_name <- paste0("_temp_svg_", substr(digest::digest(node_svg), 1, 8))
|
| 203 | 1x |
if (!temp_name %in% list_svg_shapes()) {
|
| 204 | 1x |
tryCatch( |
| 205 | 1x |
register_svg_shape(temp_name, node_svg), |
| 206 | 1x |
error = function(e) warning("Failed to register SVG: ", e$message, call. = FALSE)
|
| 207 |
) |
|
| 208 |
} |
|
| 209 | 1x |
aes$shape <- temp_name |
| 210 |
} |
|
| 211 |
} |
|
| 212 | ||
| 213 | 651x |
if (!is.null(svg_preserve_aspect)) {
|
| 214 | 1x |
aes$svg_preserve_aspect <- svg_preserve_aspect |
| 215 |
} |
|
| 216 | ||
| 217 | 651x |
if (!is.null(fill)) {
|
| 218 | 53x |
aes$fill <- resolve_aesthetic(fill, nodes_df, n) |
| 219 |
} |
|
| 220 | ||
| 221 | 651x |
if (!is.null(border_color)) {
|
| 222 | 7x |
aes$border_color <- resolve_aesthetic(border_color, nodes_df, n) |
| 223 |
} |
|
| 224 | ||
| 225 | 651x |
if (!is.null(border_width)) {
|
| 226 | 7x |
aes$border_width <- resolve_aesthetic(border_width, nodes_df, n) |
| 227 |
} |
|
| 228 | ||
| 229 | 651x |
if (!is.null(alpha)) {
|
| 230 | 22x |
validate_range(alpha, 0, 1, "alpha") |
| 231 | 16x |
aes$alpha <- resolve_aesthetic(alpha, nodes_df, n) |
| 232 |
} |
|
| 233 | ||
| 234 | 645x |
if (!is.null(label_size)) {
|
| 235 | 5x |
aes$label_size <- resolve_aesthetic(label_size, nodes_df, n) |
| 236 |
} |
|
| 237 | ||
| 238 | 645x |
if (!is.null(label_color)) {
|
| 239 | 5x |
aes$label_color <- resolve_aesthetic(label_color, nodes_df, n) |
| 240 |
} |
|
| 241 | ||
| 242 | 645x |
if (!is.null(label_position)) {
|
| 243 | 16x |
valid_pos <- c("center", "above", "below", "left", "right")
|
| 244 | 16x |
if (!all(label_position %in% valid_pos)) {
|
| 245 | 3x |
stop("label_position must be one of: ", paste(valid_pos, collapse = ", "),
|
| 246 | 3x |
call. = FALSE) |
| 247 |
} |
|
| 248 | 13x |
aes$label_position <- resolve_aesthetic(label_position, nodes_df, n) |
| 249 |
} |
|
| 250 | ||
| 251 | 642x |
if (!is.null(show_labels)) {
|
| 252 | 10x |
aes$show_labels <- show_labels |
| 253 |
} |
|
| 254 | ||
| 255 | 642x |
if (!is.null(pie_values)) {
|
| 256 | 18x |
aes$pie_values <- pie_values |
| 257 |
} |
|
| 258 | ||
| 259 | 642x |
if (!is.null(pie_colors)) {
|
| 260 | 11x |
aes$pie_colors <- pie_colors |
| 261 |
} |
|
| 262 | ||
| 263 | 642x |
if (!is.null(pie_border_width)) {
|
| 264 | 4x |
aes$pie_border_width <- pie_border_width |
| 265 |
} |
|
| 266 | ||
| 267 | 642x |
if (!is.null(donut_fill)) {
|
| 268 |
# donut_fill is the new simplified API - single value (0-1) for fill proportion |
|
| 269 |
# Convert to list format for internal use |
|
| 270 | 5x |
aes$donut_fill <- donut_fill |
| 271 |
# Also set donut_values for backwards compatibility with drawing functions |
|
| 272 | 5x |
aes$donut_values <- donut_fill |
| 273 | 637x |
} else if (!is.null(donut_values)) {
|
| 274 | 43x |
aes$donut_values <- donut_values |
| 275 |
} |
|
| 276 | ||
| 277 | 642x |
if (!is.null(donut_color)) {
|
| 278 | 3x |
aes$donut_color <- donut_color |
| 279 | 639x |
} else if (!is.null(donut_colors)) {
|
| 280 |
# Deprecated: use donut_colors as fallback |
|
| 281 | 41x |
aes$donut_color <- donut_colors |
| 282 |
} |
|
| 283 | ||
| 284 | 642x |
if (!is.null(donut_border_width)) {
|
| 285 | 5x |
aes$donut_border_width <- donut_border_width |
| 286 |
} |
|
| 287 | ||
| 288 | 642x |
if (!is.null(donut_inner_ratio)) {
|
| 289 | 7x |
aes$donut_inner_ratio <- donut_inner_ratio |
| 290 |
} |
|
| 291 | ||
| 292 | 642x |
if (!is.null(donut_bg_color)) {
|
| 293 | 7x |
aes$donut_bg_color <- donut_bg_color |
| 294 |
} |
|
| 295 | ||
| 296 | 642x |
if (!is.null(donut_shape)) {
|
| 297 | 516x |
valid_shapes <- c("circle", "square", "hexagon", "triangle", "diamond", "pentagon")
|
| 298 |
# Handle vectorized donut_shape (can be per-node) |
|
| 299 | 516x |
if (!all(donut_shape %in% valid_shapes)) {
|
| 300 | 2x |
invalid <- unique(donut_shape[!donut_shape %in% valid_shapes]) |
| 301 | 2x |
stop("donut_shape must be one of: ", paste(valid_shapes, collapse = ", "),
|
| 302 | 2x |
". Invalid values: ", paste(invalid, collapse = ", "), |
| 303 | 2x |
call. = FALSE) |
| 304 |
} |
|
| 305 | 514x |
aes$donut_shape <- donut_shape |
| 306 |
} |
|
| 307 | ||
| 308 | 640x |
if (!is.null(donut_show_value)) {
|
| 309 | 8x |
aes$donut_show_value <- donut_show_value |
| 310 |
} |
|
| 311 | ||
| 312 | 640x |
if (!is.null(donut_value_size)) {
|
| 313 | 2x |
aes$donut_value_size <- donut_value_size |
| 314 |
} |
|
| 315 | ||
| 316 | 640x |
if (!is.null(donut_value_color)) {
|
| 317 | 2x |
aes$donut_value_color <- donut_value_color |
| 318 |
} |
|
| 319 | ||
| 320 | 640x |
if (!is.null(donut_value_fontface)) {
|
| 321 | 510x |
valid_faces <- c("plain", "bold", "italic", "bold.italic")
|
| 322 | 510x |
if (!donut_value_fontface %in% valid_faces) {
|
| 323 | 2x |
stop("donut_value_fontface must be one of: ", paste(valid_faces, collapse = ", "),
|
| 324 | 2x |
call. = FALSE) |
| 325 |
} |
|
| 326 | 508x |
aes$donut_value_fontface <- donut_value_fontface |
| 327 |
} |
|
| 328 | ||
| 329 | 638x |
if (!is.null(donut_value_fontfamily)) {
|
| 330 | 504x |
aes$donut_value_fontfamily <- donut_value_fontfamily |
| 331 |
} |
|
| 332 | ||
| 333 | 638x |
if (!is.null(donut_value_digits)) {
|
| 334 | 505x |
aes$donut_value_digits <- donut_value_digits |
| 335 |
} |
|
| 336 | ||
| 337 | 638x |
if (!is.null(donut_value_prefix)) {
|
| 338 | 505x |
aes$donut_value_prefix <- donut_value_prefix |
| 339 |
} |
|
| 340 | ||
| 341 | 638x |
if (!is.null(donut_value_suffix)) {
|
| 342 | 505x |
aes$donut_value_suffix <- donut_value_suffix |
| 343 |
} |
|
| 344 | ||
| 345 | 638x |
if (!is.null(donut_value_format)) {
|
| 346 | 3x |
if (!is.function(donut_value_format)) {
|
| 347 | 2x |
stop("donut_value_format must be a function", call. = FALSE)
|
| 348 |
} |
|
| 349 | 1x |
aes$donut_value_format <- donut_value_format |
| 350 |
} |
|
| 351 | ||
| 352 | 636x |
if (!is.null(donut2_values)) {
|
| 353 | 7x |
aes$donut2_values <- donut2_values |
| 354 |
} |
|
| 355 | ||
| 356 | 636x |
if (!is.null(donut2_colors)) {
|
| 357 | 3x |
aes$donut2_colors <- donut2_colors |
| 358 |
} |
|
| 359 | ||
| 360 | 636x |
if (!is.null(donut2_inner_ratio)) {
|
| 361 | 505x |
aes$donut2_inner_ratio <- donut2_inner_ratio |
| 362 |
} |
|
| 363 | ||
| 364 | 636x |
if (!is.null(label_fontface)) {
|
| 365 | 10x |
valid_faces <- c("plain", "bold", "italic", "bold.italic")
|
| 366 | 10x |
if (!label_fontface %in% valid_faces) {
|
| 367 | 2x |
stop("label_fontface must be one of: ", paste(valid_faces, collapse = ", "),
|
| 368 | 2x |
call. = FALSE) |
| 369 |
} |
|
| 370 | 8x |
aes$label_fontface <- label_fontface |
| 371 |
} |
|
| 372 | ||
| 373 | 634x |
if (!is.null(label_fontfamily)) {
|
| 374 | 1x |
aes$label_fontfamily <- label_fontfamily |
| 375 |
} |
|
| 376 | ||
| 377 | 634x |
if (!is.null(label_hjust)) {
|
| 378 | 1x |
aes$label_hjust <- label_hjust |
| 379 |
} |
|
| 380 | ||
| 381 | 634x |
if (!is.null(label_vjust)) {
|
| 382 | 1x |
aes$label_vjust <- label_vjust |
| 383 |
} |
|
| 384 | ||
| 385 | 634x |
if (!is.null(label_angle)) {
|
| 386 | 1x |
aes$label_angle <- label_angle |
| 387 |
} |
|
| 388 | ||
| 389 | 634x |
if (!is.null(node_names)) {
|
| 390 | 2x |
aes$node_names <- resolve_aesthetic(node_names, nodes_df, n) |
| 391 |
} |
|
| 392 | ||
| 393 |
# Apply aesthetics |
|
| 394 | 634x |
new_net$set_node_aes(aes) |
| 395 | ||
| 396 |
# Return wrapped object |
|
| 397 | 634x |
as_cograph_network(new_net) |
| 398 |
} |
|
| 399 | ||
| 400 |
#' Map Node Colors by Group |
|
| 401 |
#' |
|
| 402 |
#' Helper function to map node colors based on group membership. |
|
| 403 |
#' |
|
| 404 |
#' @param groups Vector of group assignments. |
|
| 405 |
#' @param palette Color palette (function or character vector). |
|
| 406 |
#' @return Character vector of colors. |
|
| 407 |
#' @keywords internal |
|
| 408 |
map_node_colors <- function(groups, palette = NULL) {
|
|
| 409 | 3x |
groups <- as.factor(groups) |
| 410 | 3x |
n_groups <- length(levels(groups)) |
| 411 | ||
| 412 | 3x |
if (is.null(palette)) {
|
| 413 | 1x |
colors <- palette_colorblind(n_groups) |
| 414 | 2x |
} else if (is.function(palette)) {
|
| 415 | 1x |
colors <- palette(n_groups) |
| 416 |
} else {
|
|
| 417 | 1x |
colors <- rep(palette, length.out = n_groups) |
| 418 |
} |
|
| 419 | ||
| 420 | 3x |
colors[as.integer(groups)] |
| 421 |
} |
|
| 422 | ||
| 423 |
#' Scale Node Sizes |
|
| 424 |
#' |
|
| 425 |
#' Scale node sizes based on a numeric variable. |
|
| 426 |
#' |
|
| 427 |
#' @param values Numeric values to scale. |
|
| 428 |
#' @param range Target size range (min, max). |
|
| 429 |
#' @return Scaled size values. |
|
| 430 |
#' @keywords internal |
|
| 431 |
scale_node_sizes <- function(values, range = c(0.03, 0.1)) {
|
|
| 432 | 1x |
if (all(is.na(values))) return(rep(mean(range), length(values))) |
| 433 | ||
| 434 | 2x |
val_range <- range(values, na.rm = TRUE) |
| 435 | ||
| 436 | 2x |
if (diff(val_range) == 0) {
|
| 437 | 1x |
return(rep(mean(range), length(values))) |
| 438 |
} |
|
| 439 | ||
| 440 |
# Linear scaling |
|
| 441 | 1x |
scaled <- (values - val_range[1]) / diff(val_range) |
| 442 | 1x |
range[1] + scaled * diff(range) |
| 443 |
} |
| 1 |
#' Gephi Fruchterman-Reingold Layout |
|
| 2 |
#' |
|
| 3 |
#' Force-directed layout that replicates Gephi's Fruchterman-Reingold algorithm. |
|
| 4 |
#' This is a strict port of the Java implementation from Gephi's source code. |
|
| 5 |
#' |
|
| 6 |
#' @param g An igraph graph object. |
|
| 7 |
#' @param area Area parameter controlling node spread. Default 10000. |
|
| 8 |
#' @param gravity Gravity force pulling nodes toward center. Default 10.0. |
|
| 9 |
#' @param speed Speed/cooling parameter. Default 1.0. |
|
| 10 |
#' @param niter Number of iterations. Default 100. |
|
| 11 |
#' |
|
| 12 |
#' @return A matrix with x,y coordinates for each node. |
|
| 13 |
#' |
|
| 14 |
#' @details |
|
| 15 |
#' This layout is a direct port of Gephi's ForceAtlas algorithm variant of |
|
| 16 | ||
| 17 |
#' Fruchterman-Reingold. Key differences from igraph's layout_with_fr: |
|
| 18 |
#' \itemize{
|
|
| 19 |
#' \item Uses Gephi's specific constants (SPEED_DIVISOR=800, AREA_MULTIPLICATOR=10000) |
|
| 20 |
#' \item Includes configurable gravity toward center |
|
| 21 |
#' \item Different cooling/speed mechanism |
|
| 22 |
#' } |
|
| 23 |
#' |
|
| 24 |
#' @examples |
|
| 25 |
#' \dontrun{
|
|
| 26 |
#' library(igraph) |
|
| 27 |
#' g <- make_ring(10) |
|
| 28 |
#' coords <- layout_gephi_fr(g) |
|
| 29 |
#' plot(g, layout = coords) |
|
| 30 |
#' } |
|
| 31 |
#' |
|
| 32 |
#' @keywords internal |
|
| 33 |
layout_gephi_fr <- function(g, area = 10000, gravity = 10.0, speed = 1.0, niter = 100) {
|
|
| 34 | ||
| 35 | ||
| 36 |
# 1. Setup & Constants (Directly from Java source) |
|
| 37 | 37x |
SPEED_DIVISOR <- 800.0 |
| 38 | 37x |
AREA_MULTIPLICATOR <- 10000.0 |
| 39 | ||
| 40 |
# Get graph data |
|
| 41 | ||
| 42 | 37x |
nodes_count <- igraph::vcount(g) |
| 43 | 3x |
if (nodes_count == 0) return(matrix(numeric(0), ncol = 2)) |
| 44 | ||
| 45 |
# Initialize positions (Random -500 to 500, roughly matching Gephi's random init) |
|
| 46 | 34x |
coords <- matrix(runif(nodes_count * 2, min = -500, max = 500), ncol = 2) |
| 47 | ||
| 48 |
# Get Edge List (1-based indices for R) |
|
| 49 | 34x |
edges <- igraph::as_edgelist(g, names = FALSE) |
| 50 | 34x |
has_edges <- nrow(edges) > 0 |
| 51 | ||
| 52 |
# 2. Pre-calculate Constants (Java: initAlgo / goAlgo start) |
|
| 53 |
# Java: float k = (float) Math.sqrt((AREA_MULTIPLICATOR * area) / (1f + nodes.length)); |
|
| 54 | 34x |
k <- sqrt((AREA_MULTIPLICATOR * area) / (1.0 + nodes_count)) |
| 55 | ||
| 56 |
# Java: float maxDisplace = (float) (Math.sqrt(AREA_MULTIPLICATOR * area) / 10f); |
|
| 57 | 34x |
max_displace <- sqrt(AREA_MULTIPLICATOR * area) / 10.0 |
| 58 | ||
| 59 |
# 3. Main Algorithm Loop (Replicates 'goAlgo' repeated niter times) |
|
| 60 | 34x |
for (iter in 1:niter) {
|
| 61 | ||
| 62 |
# Initialize displacements to 0 for this pass |
|
| 63 | 2355x |
disp <- matrix(0, nrow = nodes_count, ncol = 2) |
| 64 | ||
| 65 |
# --- REPULSION (All Nodes vs All Nodes) --- |
|
| 66 |
# We use outer product to get matrix of all xDist and yDist |
|
| 67 | 2355x |
dx_mat <- outer(coords[, 1], coords[, 1], "-") # N1.x - N2.x |
| 68 | 2355x |
dy_mat <- outer(coords[, 2], coords[, 2], "-") # N1.y - N2.y |
| 69 | ||
| 70 | 2355x |
sq_dist_mat <- dx_mat^2 + dy_mat^2 |
| 71 | 2355x |
dist_mat <- sqrt(sq_dist_mat) |
| 72 | ||
| 73 |
# Avoid division by zero |
|
| 74 | 2355x |
safe_sq_dist <- sq_dist_mat |
| 75 | 2355x |
safe_sq_dist[safe_sq_dist == 0] <- Inf |
| 76 | ||
| 77 |
# Java: float repulsiveF = k * k / dist; |
|
| 78 |
# Simplified: force = xDist * (k^2 / dist^2) |
|
| 79 | 2355x |
factor <- (k^2) / safe_sq_dist |
| 80 | ||
| 81 |
# Apply forces |
|
| 82 | 2355x |
disp[, 1] <- disp[, 1] + rowSums(dx_mat * factor) |
| 83 | 2355x |
disp[, 2] <- disp[, 2] + rowSums(dy_mat * factor) |
| 84 | ||
| 85 |
# --- ATTRACTION (Edges Only) --- |
|
| 86 | 2355x |
if (has_edges) {
|
| 87 | 2040x |
src_indices <- edges[, 1] |
| 88 | 2040x |
tgt_indices <- edges[, 2] |
| 89 | ||
| 90 | 2040x |
x_dist <- coords[src_indices, 1] - coords[tgt_indices, 1] |
| 91 | 2040x |
y_dist <- coords[src_indices, 2] - coords[tgt_indices, 2] |
| 92 | ||
| 93 | 2040x |
dist <- sqrt(x_dist^2 + y_dist^2) |
| 94 | ||
| 95 | 2040x |
mask <- dist > 0 |
| 96 | ||
| 97 | 2040x |
if (any(mask)) {
|
| 98 | 2040x |
x_d <- x_dist[mask] |
| 99 | 2040x |
y_d <- y_dist[mask] |
| 100 | 2040x |
d <- dist[mask] |
| 101 | ||
| 102 |
# Java: float attractiveF = dist * dist / k; |
|
| 103 |
# Simplified: source.dx -= xDist * dist / k |
|
| 104 | 2040x |
force_factor <- d / k |
| 105 | ||
| 106 | 2040x |
fx <- x_d * force_factor |
| 107 | 2040x |
fy <- y_d * force_factor |
| 108 | ||
| 109 |
# Update Sources (subtract) - aggregate by index |
|
| 110 | 2040x |
fx_src_accum <- tapply(fx, src_indices[mask], sum) |
| 111 | 2040x |
fy_src_accum <- tapply(fy, src_indices[mask], sum) |
| 112 | ||
| 113 | 2040x |
src_rows <- as.integer(names(fx_src_accum)) |
| 114 | 2040x |
disp[src_rows, 1] <- disp[src_rows, 1] - fx_src_accum |
| 115 | 2040x |
disp[src_rows, 2] <- disp[src_rows, 2] - fy_src_accum |
| 116 | ||
| 117 |
# Update Targets (add) |
|
| 118 | 2040x |
fx_tgt_accum <- tapply(fx, tgt_indices[mask], sum) |
| 119 | 2040x |
fy_tgt_accum <- tapply(fy, tgt_indices[mask], sum) |
| 120 | ||
| 121 | 2040x |
tgt_rows <- as.integer(names(fx_tgt_accum)) |
| 122 | 2040x |
disp[tgt_rows, 1] <- disp[tgt_rows, 1] + fx_tgt_accum |
| 123 | 2040x |
disp[tgt_rows, 2] <- disp[tgt_rows, 2] + fy_tgt_accum |
| 124 |
} |
|
| 125 |
} |
|
| 126 | ||
| 127 |
# --- GRAVITY --- |
|
| 128 |
# Simplified: 0.01 * k * gravity * x (linear form, robust at center) |
|
| 129 | 2355x |
gravity_factor <- 0.01 * k * gravity |
| 130 | ||
| 131 | 2355x |
disp[, 1] <- disp[, 1] - (coords[, 1] * gravity_factor) |
| 132 | 2355x |
disp[, 2] <- disp[, 2] - (coords[, 2] * gravity_factor) |
| 133 | ||
| 134 |
# --- SPEED (Cooling) --- |
|
| 135 | 2355x |
speed_ratio <- speed / SPEED_DIVISOR |
| 136 | 2355x |
disp <- disp * speed_ratio |
| 137 | ||
| 138 |
# --- APPLY DISPLACEMENT --- |
|
| 139 | 2355x |
disp_dist <- sqrt(disp[, 1]^2 + disp[, 2]^2) |
| 140 | ||
| 141 | 2355x |
move_mask <- disp_dist > 0 |
| 142 | ||
| 143 | 2355x |
if (any(move_mask)) {
|
| 144 | 2355x |
limit_val <- max_displace * speed_ratio |
| 145 | ||
| 146 |
# Calculate scaling factor |
|
| 147 | 2355x |
scale_factors <- rep(1, nodes_count) |
| 148 | ||
| 149 | 2355x |
limited_mask <- move_mask & (disp_dist > limit_val) |
| 150 | 2355x |
scale_factors[limited_mask] <- limit_val / disp_dist[limited_mask] |
| 151 | ||
| 152 | 2355x |
coords[move_mask, 1] <- coords[move_mask, 1] + (disp[move_mask, 1] * scale_factors[move_mask]) |
| 153 | 2355x |
coords[move_mask, 2] <- coords[move_mask, 2] + (disp[move_mask, 2] * scale_factors[move_mask]) |
| 154 |
} |
|
| 155 |
} |
|
| 156 | ||
| 157 | 34x |
return(coords) |
| 158 |
} |
|
| 159 | ||
| 160 | ||
| 161 |
#' Wrapper for Gephi FR Layout (for layout registry) |
|
| 162 |
#' |
|
| 163 |
#' @param network A cograph_network object. |
|
| 164 |
#' @param area Area parameter. Default 10000. |
|
| 165 |
#' @param gravity Gravity force. Default 10.0. |
|
| 166 |
#' @param speed Speed parameter. Default 1.0. |
|
| 167 |
#' @param niter Number of iterations. Default 100. |
|
| 168 |
#' @param ... Additional arguments (ignored). |
|
| 169 |
#' |
|
| 170 |
#' @return Data frame with x, y coordinates. |
|
| 171 |
#' @keywords internal |
|
| 172 |
compute_layout_gephi_fr <- function(network, area = 10000, gravity = 10.0, |
|
| 173 |
speed = 1.0, niter = 100, ...) {
|
|
| 174 | 21x |
g <- network_to_igraph(network) |
| 175 | 21x |
coords <- layout_gephi_fr(g, area = area, gravity = gravity, |
| 176 | 21x |
speed = speed, niter = niter) |
| 177 | ||
| 178 | 21x |
data.frame( |
| 179 | 21x |
x = coords[, 1], |
| 180 | 21x |
y = coords[, 2] |
| 181 |
) |
|
| 182 |
} |
| 1 |
#' @title Input Parsing Functions |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing network input into internal format. |
|
| 4 |
#' @name input-parse |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse Network Input |
|
| 8 |
#' |
|
| 9 |
#' Automatically detects input type and converts to internal format. |
|
| 10 |
#' |
|
| 11 |
#' @param input Network input: matrix, data.frame (edge list), or igraph object. |
|
| 12 |
#' @param directed Logical. Force directed interpretation. NULL for auto-detect. |
|
| 13 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 14 |
#' @keywords internal |
|
| 15 |
parse_input <- function(input, directed = NULL) {
|
|
| 16 |
# Detect input type |
|
| 17 | 1714x |
if (is.matrix(input)) {
|
| 18 | 1673x |
parse_matrix(input, directed = directed) |
| 19 | 41x |
} else if (is.data.frame(input)) {
|
| 20 | 22x |
parse_edgelist(input, directed = directed) |
| 21 | 19x |
} else if (inherits(input, "igraph")) {
|
| 22 | 8x |
parse_igraph(input, directed = directed) |
| 23 | 11x |
} else if (inherits(input, "network")) {
|
| 24 | 2x |
parse_statnet(input, directed = directed) |
| 25 | 9x |
} else if (inherits(input, "qgraph")) {
|
| 26 | 2x |
parse_qgraph(input, directed = directed) |
| 27 | 7x |
} else if (inherits(input, "tna")) {
|
| 28 | 2x |
parse_tna(input, directed = directed) |
| 29 | 5x |
} else if (is.list(input) && !is.null(input$edges)) {
|
| 30 |
# Already parsed format |
|
| 31 | 1x |
input |
| 32 |
} else {
|
|
| 33 | 4x |
stop("Unsupported input type. Expected matrix, data.frame, igraph, network, qgraph, or tna object.",
|
| 34 | 4x |
call. = FALSE) |
| 35 |
} |
|
| 36 |
} |
|
| 37 | ||
| 38 |
#' Detect if Matrix is Symmetric |
|
| 39 |
#' |
|
| 40 |
#' @param m A matrix. |
|
| 41 |
#' @param tol Tolerance for comparison. |
|
| 42 |
#' @return Logical. |
|
| 43 |
#' @keywords internal |
|
| 44 |
is_symmetric_matrix <- function(m, tol = .Machine$double.eps^0.5) {
|
|
| 45 | 2x |
if (!is.matrix(m)) return(FALSE) |
| 46 | 1x |
if (nrow(m) != ncol(m)) return(FALSE) |
| 47 | 1658x |
isTRUE(all.equal(m, t(m), tolerance = tol, check.attributes = FALSE)) |
| 48 |
} |
|
| 49 | ||
| 50 |
#' Create Node Data Frame |
|
| 51 |
#' |
|
| 52 |
#' @param n Number of nodes. |
|
| 53 |
#' @param labels Optional node labels. |
|
| 54 |
#' @param names Optional node names for legend (defaults to labels). |
|
| 55 |
#' @return Data frame with node information. |
|
| 56 |
#' @keywords internal |
|
| 57 |
create_nodes_df <- function(n, labels = NULL, names = NULL) {
|
|
| 58 | 1768x |
if (is.null(labels)) {
|
| 59 | 2x |
labels <- as.character(seq_len(n)) |
| 60 |
} |
|
| 61 | ||
| 62 | 1768x |
if (is.null(names)) {
|
| 63 | 1767x |
names <- labels |
| 64 |
} |
|
| 65 | ||
| 66 | 1768x |
data.frame( |
| 67 | 1768x |
id = seq_len(n), |
| 68 | 1768x |
label = labels, |
| 69 | 1768x |
name = names, |
| 70 | 1768x |
x = NA_real_, |
| 71 | 1768x |
y = NA_real_, |
| 72 | 1768x |
stringsAsFactors = FALSE |
| 73 |
) |
|
| 74 |
} |
|
| 75 | ||
| 76 |
#' Create Edge Data Frame |
|
| 77 |
#' |
|
| 78 |
#' @param from Vector of source node indices. |
|
| 79 |
#' @param to Vector of target node indices. |
|
| 80 |
#' @param weight Vector of edge weights. |
|
| 81 |
#' @param directed Logical. Is the network directed? |
|
| 82 |
#' @return Data frame with edge information. |
|
| 83 |
#' @keywords internal |
|
| 84 |
create_edges_df <- function(from, to, weight = NULL, directed = FALSE) {
|
|
| 85 | 1765x |
if (is.null(weight)) {
|
| 86 | 2x |
weight <- rep(1, length(from)) |
| 87 |
} |
|
| 88 | ||
| 89 | 1765x |
data.frame( |
| 90 | 1765x |
from = from, |
| 91 | 1765x |
to = to, |
| 92 | 1765x |
weight = weight, |
| 93 | 1765x |
stringsAsFactors = FALSE |
| 94 |
) |
|
| 95 |
} |
|
| 96 | ||
| 97 |
#' Detect Duplicate Edges in Undirected Network |
|
| 98 |
#' |
|
| 99 |
#' Identifies edges that appear multiple times between the same pair of nodes. |
|
| 100 |
#' For undirected networks, edges A\code{->}B and B\code{->}A are considered duplicates.
|
|
| 101 |
#' For directed networks, only identical from\code{->}to pairs are duplicates.
|
|
| 102 |
#' |
|
| 103 |
#' @param edges Data frame with \code{from} and \code{to} columns (and optionally
|
|
| 104 |
#' \code{weight}).
|
|
| 105 |
#' |
|
| 106 |
#' @details |
|
| 107 |
#' This function is useful for cleaning network data before visualization. |
|
| 108 |
#' Duplicate edges can arise from: |
|
| 109 |
#' \itemize{
|
|
| 110 |
#' \item Data collection errors (same edge recorded twice) |
|
| 111 |
#' \item Combining multiple data sources |
|
| 112 |
#' \item Converting from formats that allow multi-edges |
|
| 113 |
#' \item Edge lists that include both A\code{->}B and B\code{->}A for undirected networks
|
|
| 114 |
#' } |
|
| 115 |
#' |
|
| 116 |
#' The function creates canonical keys by sorting node pairs (lower index first), |
|
| 117 |
#' so edges 1\code{->}2 and 2\code{->}1 map to the same key "1-2" in undirected mode.
|
|
| 118 |
#' |
|
| 119 |
#' @return A list with two components: |
|
| 120 |
#' \describe{
|
|
| 121 |
#' \item{has_duplicates}{Logical indicating whether any duplicates were found.}
|
|
| 122 |
#' \item{info}{A list of duplicate details, where each element contains:
|
|
| 123 |
#' \code{nodes} (the node pair), \code{count} (number of edges), and
|
|
| 124 |
#' \code{weights} (vector of weights if available).}
|
|
| 125 |
#' } |
|
| 126 |
#' |
|
| 127 |
#' @seealso \code{\link{aggregate_duplicate_edges}} for combining duplicates into
|
|
| 128 |
#' single edges |
|
| 129 |
#' |
|
| 130 |
#' @examples |
|
| 131 |
#' \dontrun{
|
|
| 132 |
#' # Create edges with duplicates |
|
| 133 |
#' edges <- data.frame( |
|
| 134 |
#' from = c(1, 1, 2, 2, 3), |
|
| 135 |
#' to = c(2, 2, 3, 1, 1), |
|
| 136 |
#' weight = c(0.5, 0.3, 0.4, 0.6, 0.2) |
|
| 137 |
#' ) |
|
| 138 |
#' |
|
| 139 |
#' # Detect duplicates (undirected: 1-2 appears 3 times, 1-3 appears 2 times) |
|
| 140 |
#' result <- detect_duplicate_edges(edges) |
|
| 141 |
#' result$has_duplicates |
|
| 142 |
#' # [1] TRUE |
|
| 143 |
#' |
|
| 144 |
#' # View duplicate details |
|
| 145 |
#' result$info[[1]] |
|
| 146 |
#' # $nodes: 1, 2 |
|
| 147 |
#' # $count: 3 |
|
| 148 |
#' # $weights: 0.5, 0.3, 0.6 |
|
| 149 |
#' } |
|
| 150 |
#' |
|
| 151 |
#' @keywords internal |
|
| 152 |
detect_duplicate_edges <- function(edges) {
|
|
| 153 | 923x |
if (is.null(edges) || nrow(edges) == 0) {
|
| 154 | 2x |
return(list(has_duplicates = FALSE, info = NULL)) |
| 155 |
} |
|
| 156 | ||
| 157 |
# Create canonical keys (lower index first) |
|
| 158 | 921x |
keys <- paste(pmin(edges$from, edges$to), pmax(edges$from, edges$to), sep = "-") |
| 159 | 921x |
dup_keys <- keys[duplicated(keys)] |
| 160 | ||
| 161 | 921x |
if (length(dup_keys) == 0) {
|
| 162 | 913x |
return(list(has_duplicates = FALSE, info = NULL)) |
| 163 |
} |
|
| 164 | ||
| 165 |
# Build info about duplicates |
|
| 166 | 8x |
info <- lapply(unique(dup_keys), function(k) {
|
| 167 | 10x |
idx <- which(keys == k) |
| 168 | 10x |
list( |
| 169 | 10x |
nodes = as.numeric(strsplit(k, "-")[[1]]), |
| 170 | 10x |
count = length(idx), |
| 171 | 10x |
weights = if ("weight" %in% names(edges)) edges$weight[idx] else rep(1, length(idx))
|
| 172 |
) |
|
| 173 |
}) |
|
| 174 | ||
| 175 | 8x |
list(has_duplicates = TRUE, info = info) |
| 176 |
} |
|
| 177 | ||
| 178 |
#' Aggregate Duplicate Edges |
|
| 179 |
#' |
|
| 180 |
#' Combines duplicate edges by aggregating their weights using a specified |
|
| 181 |
#' function (sum, mean, max, min, or first). |
|
| 182 |
#' |
|
| 183 |
#' @param edges Data frame with \code{from}, \code{to}, and \code{weight} columns.
|
|
| 184 |
#' @param method Aggregation method: \code{"sum"} (default), \code{"mean"},
|
|
| 185 |
#' \code{"max"}, \code{"min"}, \code{"first"}, or a custom function that
|
|
| 186 |
#' takes a numeric vector and returns a single value. |
|
| 187 |
#' |
|
| 188 |
#' @details |
|
| 189 |
#' ## Aggregation Methods |
|
| 190 |
#' \describe{
|
|
| 191 |
#' \item{\strong{sum}}{Total weight of all duplicate edges. Useful for frequency
|
|
| 192 |
#' counts or when edges represent additive quantities (e.g., number of emails).} |
|
| 193 |
#' \item{\strong{mean}}{Average weight. Useful for averaging multiple measurements
|
|
| 194 |
#' or when duplicates represent repeated observations.} |
|
| 195 |
#' \item{\strong{max}}{Maximum weight. Useful for finding the strongest connection
|
|
| 196 |
#' or most recent value. |
|
| 197 |
#' } |
|
| 198 |
#' \item{\strong{min}}{Minimum weight. Useful for the most conservative estimate
|
|
| 199 |
#' or earliest value.} |
|
| 200 |
#' \item{\strong{first}}{Keep first occurrence. Useful for preserving original
|
|
| 201 |
#' order or when duplicates are erroneous.} |
|
| 202 |
#' } |
|
| 203 |
#' |
|
| 204 |
#' The output edge list uses canonical node ordering (lower index first for |
|
| 205 |
#' undirected networks), ensuring consistent from/to assignment. |
|
| 206 |
#' |
|
| 207 |
#' @return A deduplicated data frame with the same columns as the input, where |
|
| 208 |
#' each node pair appears only once with its aggregated weight. |
|
| 209 |
#' |
|
| 210 |
#' @seealso \code{\link{detect_duplicate_edges}} for identifying duplicates before
|
|
| 211 |
#' aggregation |
|
| 212 |
#' |
|
| 213 |
#' @examples |
|
| 214 |
#' \dontrun{
|
|
| 215 |
#' # Create edges with duplicates |
|
| 216 |
#' edges <- data.frame( |
|
| 217 |
#' from = c(1, 1, 2), |
|
| 218 |
#' to = c(2, 2, 3), |
|
| 219 |
#' weight = c(0.5, 0.3, 0.4) |
|
| 220 |
#' ) |
|
| 221 |
#' |
|
| 222 |
#' # Aggregate by sum (0.5 + 0.3 = 0.8) |
|
| 223 |
#' aggregate_duplicate_edges(edges, method = "sum") |
|
| 224 |
#' # from to weight |
|
| 225 |
#' # 1 1 2 0.8 |
|
| 226 |
#' # 2 2 3 0.4 |
|
| 227 |
#' |
|
| 228 |
#' # Aggregate by mean (average: 0.4) |
|
| 229 |
#' aggregate_duplicate_edges(edges, method = "mean") |
|
| 230 |
#' # from to weight |
|
| 231 |
#' # 1 1 2 0.4 |
|
| 232 |
#' # 2 2 3 0.4 |
|
| 233 |
#' |
|
| 234 |
#' # Use custom aggregation function |
|
| 235 |
#' aggregate_duplicate_edges(edges, method = function(x) sqrt(sum(x^2))) |
|
| 236 |
#' } |
|
| 237 |
#' |
|
| 238 |
#' @keywords internal |
|
| 239 |
aggregate_duplicate_edges <- function(edges, method = "mean") {
|
|
| 240 | 14x |
if (is.null(edges) || nrow(edges) == 0) {
|
| 241 | 2x |
return(edges) |
| 242 |
} |
|
| 243 | ||
| 244 | 12x |
keys <- paste(pmin(edges$from, edges$to), pmax(edges$from, edges$to), sep = "-") |
| 245 | ||
| 246 | 12x |
agg_fn <- if (is.function(method)) {
|
| 247 | 1x |
method |
| 248 |
} else {
|
|
| 249 | 11x |
switch(method, |
| 250 | 4x |
"sum" = sum, |
| 251 | 3x |
"mean" = mean, |
| 252 | 1x |
"first" = function(x) x[1], |
| 253 | 1x |
"max" = max, |
| 254 | 1x |
"min" = min, |
| 255 | 1x |
stop("Unknown aggregation method: ", method,
|
| 256 | 1x |
". Use 'sum', 'mean', 'first', 'max', 'min', or a custom function.", |
| 257 | 1x |
call. = FALSE) |
| 258 |
) |
|
| 259 |
} |
|
| 260 | ||
| 261 |
# Aggregate by key |
|
| 262 | 11x |
unique_keys <- unique(keys) |
| 263 | 11x |
result <- do.call(rbind, lapply(unique_keys, function(k) {
|
| 264 | 17x |
idx <- which(keys == k) |
| 265 | 17x |
row <- edges[idx[1], , drop = FALSE] |
| 266 |
# Ensure canonical order (lower index first) |
|
| 267 | 17x |
row$from <- min(edges$from[idx[1]], edges$to[idx[1]]) |
| 268 | 17x |
row$to <- max(edges$from[idx[1]], edges$to[idx[1]]) |
| 269 | 17x |
if ("weight" %in% names(row)) {
|
| 270 | 17x |
row$weight <- agg_fn(edges$weight[idx]) |
| 271 |
} |
|
| 272 | 17x |
row |
| 273 |
})) |
|
| 274 | 11x |
rownames(result) <- NULL |
| 275 | 11x |
result |
| 276 |
} |
| 1 |
#' @title Edge Rendering |
|
| 2 |
#' @description Functions for rendering edges using grid graphics. |
|
| 3 |
#' @name render-edges |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Render All Edges |
|
| 8 |
#' |
|
| 9 |
#' Create grid grobs for all edges in the network. |
|
| 10 |
#' |
|
| 11 |
#' @param network A CographNetwork object. |
|
| 12 |
#' @return A grid gList of edge grobs. |
|
| 13 |
#' @keywords internal |
|
| 14 |
render_edges_grid <- function(network) {
|
|
| 15 | 510x |
nodes <- network$get_nodes() |
| 16 | 510x |
edges <- network$get_edges() |
| 17 | 510x |
aes <- network$get_edge_aes() |
| 18 | 510x |
node_aes <- network$get_node_aes() |
| 19 | 510x |
theme <- network$get_theme() |
| 20 | ||
| 21 | 11x |
if (is.null(edges) || nrow(edges) == 0) return(grid::gList()) |
| 22 | ||
| 23 | 499x |
m <- nrow(edges) |
| 24 | 499x |
n <- nrow(nodes) |
| 25 | ||
| 26 |
# Resolve edge widths using the enhanced scaling system |
|
| 27 | 499x |
if (!is.null(aes$width)) {
|
| 28 |
# Explicit widths provided |
|
| 29 | 494x |
widths <- recycle_to_length(aes$width, m) |
| 30 | 5x |
} else if ("weight" %in% names(edges)) {
|
| 31 |
# Use weight-based scaling with new system |
|
| 32 | 3x |
widths <- scale_edge_widths( |
| 33 | 3x |
weights = edges$weight, |
| 34 | 3x |
esize = aes$esize, |
| 35 | 3x |
n_nodes = n, |
| 36 | 3x |
directed = network$is_directed, |
| 37 | 3x |
mode = if (!is.null(aes$edge_scale_mode)) aes$edge_scale_mode else "linear", |
| 38 | 3x |
maximum = aes$maximum, |
| 39 | 3x |
minimum = 0, |
| 40 | 3x |
cut = aes$cut, |
| 41 | 3x |
range = if (!is.null(aes$edge_width_range)) aes$edge_width_range else c(0.5, 4) |
| 42 |
) |
|
| 43 |
} else {
|
|
| 44 |
# No weights, use default |
|
| 45 | 2x |
widths <- recycle_to_length(theme$get("edge_width"), m)
|
| 46 |
} |
|
| 47 | ||
| 48 |
# Apply width_scale if provided (additional multiplier) |
|
| 49 | 499x |
if (!is.null(aes$width_scale)) {
|
| 50 | 1x |
widths <- widths * aes$width_scale |
| 51 |
} |
|
| 52 | ||
| 53 |
# Color resolution |
|
| 54 | 499x |
if (!is.null(aes$color)) {
|
| 55 | 494x |
colors <- recycle_to_length(aes$color, m) |
| 56 |
} else {
|
|
| 57 |
# Default: color by weight sign |
|
| 58 | 5x |
pos_col <- if (!is.null(aes$positive_color)) aes$positive_color else theme$get("edge_positive_color")
|
| 59 | 5x |
neg_col <- if (!is.null(aes$negative_color)) aes$negative_color else theme$get("edge_negative_color")
|
| 60 | 5x |
default_col <- theme$get("edge_color")
|
| 61 | 5x |
colors <- if (!is.null(edges$weight)) {
|
| 62 | 3x |
ifelse(edges$weight > 0, pos_col, ifelse(edges$weight < 0, neg_col, default_col)) |
| 63 |
} else {
|
|
| 64 | 2x |
rep(default_col, m) |
| 65 |
} |
|
| 66 |
} |
|
| 67 | ||
| 68 | 499x |
alphas <- recycle_to_length( |
| 69 | 499x |
if (!is.null(aes$alpha)) aes$alpha else 0.8, |
| 70 | 499x |
m |
| 71 |
) |
|
| 72 | ||
| 73 |
# Apply cut threshold for transparency: edges below cut are faded |
|
| 74 | 499x |
if (!is.null(aes$cut) && aes$cut > 0 && "weight" %in% names(edges)) {
|
| 75 | 5x |
cut_val <- aes$cut |
| 76 | 5x |
abs_weights <- abs(edges$weight) |
| 77 |
# Edges below cut get reduced alpha (pale/faded) |
|
| 78 | 5x |
below_cut <- abs_weights < cut_val |
| 79 | 5x |
if (any(below_cut)) {
|
| 80 |
# Scale alpha: edges at 0 get 20% of normal alpha, edges near cut get full alpha |
|
| 81 | 3x |
fade_factor <- ifelse(below_cut, 0.2 + 0.8 * (abs_weights / cut_val), 1) |
| 82 | 3x |
alphas <- alphas * fade_factor |
| 83 |
} |
|
| 84 |
} |
|
| 85 | ||
| 86 | 499x |
styles <- recycle_to_length( |
| 87 | 499x |
if (!is.null(aes$style)) aes$style else "solid", |
| 88 | 499x |
m |
| 89 |
) |
|
| 90 | 499x |
curvatures <- recycle_to_length( |
| 91 | 499x |
if (!is.null(aes$curvature)) aes$curvature else 0, |
| 92 | 499x |
m |
| 93 |
) |
|
| 94 | ||
| 95 |
# Get curves mode: |
|
| 96 |
# TRUE (default) = single edges straight, reciprocal edges curve as ellipse (opposite directions) |
|
| 97 |
# FALSE = all straight |
|
| 98 |
# "force" = all curved (reciprocals opposite, singles curved) |
|
| 99 | 499x |
curves_mode <- if (!is.null(aes$curves)) aes$curves else TRUE |
| 100 | ||
| 101 |
# Handle curve modes |
|
| 102 | 499x |
if (!identical(curves_mode, FALSE)) {
|
| 103 |
# Identify reciprocal pairs |
|
| 104 | 495x |
is_reciprocal <- rep(FALSE, m) |
| 105 | 495x |
for (i in seq_len(m)) {
|
| 106 | 2158x |
from_i <- edges$from[i] |
| 107 | 2158x |
to_i <- edges$to[i] |
| 108 | 8x |
if (from_i == to_i) next |
| 109 | 2150x |
for (j in seq_len(m)) {
|
| 110 | 380221x |
if (j != i && edges$from[j] == to_i && edges$to[j] == from_i) {
|
| 111 | 162x |
is_reciprocal[i] <- TRUE |
| 112 | 162x |
break |
| 113 |
} |
|
| 114 |
} |
|
| 115 |
} |
|
| 116 | ||
| 117 |
# Curve reciprocal edges with direction based on network center (qgraph-style) |
|
| 118 |
# Increased from 0.18 to 0.5 for better visibility |
|
| 119 | 495x |
default_curve <- 0.25 |
| 120 | ||
| 121 |
# Calculate network center for curve direction |
|
| 122 | 495x |
center_x <- mean(nodes$x) |
| 123 | 495x |
center_y <- mean(nodes$y) |
| 124 | ||
| 125 | 495x |
for (i in seq_len(m)) {
|
| 126 | 2158x |
if (is_reciprocal[i] && curvatures[i] == 0) {
|
| 127 | 150x |
from_i <- edges$from[i] |
| 128 | 150x |
to_i <- edges$to[i] |
| 129 | ||
| 130 |
# Calculate edge midpoint |
|
| 131 | 150x |
mid_x <- (nodes$x[from_i] + nodes$x[to_i]) / 2 |
| 132 | 150x |
mid_y <- (nodes$y[from_i] + nodes$y[to_i]) / 2 |
| 133 | ||
| 134 |
# Calculate perpendicular direction (for curve) |
|
| 135 | 150x |
dx <- nodes$x[to_i] - nodes$x[from_i] |
| 136 | 150x |
dy <- nodes$y[to_i] - nodes$y[from_i] |
| 137 | ||
| 138 |
# Perpendicular vector (rotated 90 degrees) |
|
| 139 | 150x |
perp_x <- -dy |
| 140 | 150x |
perp_y <- dx |
| 141 | ||
| 142 |
# Check if positive curve moves toward or away from center |
|
| 143 | 150x |
test_x <- mid_x + perp_x * 0.1 |
| 144 | 150x |
test_y <- mid_y + perp_y * 0.1 |
| 145 | 150x |
dist_to_center_pos <- sqrt((test_x - center_x)^2 + (test_y - center_y)^2) |
| 146 | 150x |
dist_to_center_orig <- sqrt((mid_x - center_x)^2 + (mid_y - center_y)^2) |
| 147 | ||
| 148 |
# Both edges curve OUTWARD (away from center), on opposite sides |
|
| 149 |
# The perpendicular naturally reverses for the reverse edge, so same logic works |
|
| 150 | 150x |
curvatures[i] <- if (dist_to_center_pos > dist_to_center_orig) default_curve else -default_curve |
| 151 |
} |
|
| 152 |
} |
|
| 153 | ||
| 154 |
# For "force" mode, also curve non-reciprocal edges |
|
| 155 | 495x |
if (identical(curves_mode, "force")) {
|
| 156 | 8x |
for (i in seq_len(m)) {
|
| 157 | 25x |
from_i <- edges$from[i] |
| 158 | 25x |
to_i <- edges$to[i] |
| 159 | 6x |
if (is_reciprocal[i] || from_i == to_i) next |
| 160 | 19x |
if (curvatures[i] == 0) {
|
| 161 | 19x |
curvatures[i] <- default_curve |
| 162 |
} |
|
| 163 |
} |
|
| 164 |
} |
|
| 165 |
} |
|
| 166 | ||
| 167 |
# Arrow settings |
|
| 168 |
# Default arrow_size uses unified scale constant (0.02) |
|
| 169 |
# This is already in the correct format - soplot converts user input via scale$arrow_factor |
|
| 170 | 499x |
show_arrows <- if (!is.null(aes$show_arrows)) aes$show_arrows else network$is_directed |
| 171 | 499x |
arrow_size <- if (!is.null(aes$arrow_size)) aes$arrow_size else COGRAPH_SCALE$arrow_factor |
| 172 | ||
| 173 |
# Bidirectional arrow settings |
|
| 174 | 499x |
bidirectionals <- recycle_to_length( |
| 175 | 499x |
if (!is.null(aes$bidirectional)) aes$bidirectional else FALSE, |
| 176 | 499x |
m |
| 177 |
) |
|
| 178 | ||
| 179 |
# Loop rotation settings |
|
| 180 | 499x |
loop_rotations <- recycle_to_length( |
| 181 | 499x |
if (!is.null(aes$loop_rotation)) aes$loop_rotation else pi/2, |
| 182 | 499x |
m |
| 183 |
) |
|
| 184 | ||
| 185 |
# Curve shape and pivot settings |
|
| 186 | 499x |
curve_shapes <- recycle_to_length( |
| 187 | 499x |
if (!is.null(aes$curve_shape)) aes$curve_shape else 0, |
| 188 | 499x |
m |
| 189 |
) |
|
| 190 | 499x |
curve_pivots <- recycle_to_length( |
| 191 | 499x |
if (!is.null(aes$curve_pivot)) aes$curve_pivot else 0.5, |
| 192 | 499x |
m |
| 193 |
) |
|
| 194 | ||
| 195 |
# Node sizes for endpoint calculation |
|
| 196 | 499x |
node_sizes <- recycle_to_length( |
| 197 | 499x |
if (!is.null(node_aes$size)) node_aes$size else 0.05, |
| 198 | 499x |
nrow(nodes) |
| 199 |
) |
|
| 200 | ||
| 201 |
# Get aspect ratio correction for proper edge endpoints |
|
| 202 | 499x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 203 | 499x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 204 | 499x |
min_dim <- min(vp_width, vp_height) |
| 205 | 499x |
x_scale <- min_dim / vp_width |
| 206 | 499x |
y_scale <- min_dim / vp_height |
| 207 | ||
| 208 |
# CI underlay parameters |
|
| 209 | 499x |
edge_ci <- if (!is.null(aes$ci)) recycle_to_length(aes$ci, m) else NULL |
| 210 | 499x |
edge_ci_scale <- if (!is.null(aes$ci_scale)) aes$ci_scale else 2.0 |
| 211 | 499x |
edge_ci_alpha <- if (!is.null(aes$ci_alpha)) aes$ci_alpha else 0.15 |
| 212 | 499x |
edge_ci_color <- if (!is.null(aes$ci_color) && !is.na(aes$ci_color)) {
|
| 213 | 3x |
recycle_to_length(aes$ci_color, m) |
| 214 | 499x |
} else NULL |
| 215 | 499x |
edge_ci_style <- if (!is.null(aes$ci_style)) aes$ci_style else 2 |
| 216 | 499x |
edge_ci_arrows <- if (!is.null(aes$ci_arrows)) aes$ci_arrows else FALSE |
| 217 | ||
| 218 |
# Create edge grobs |
|
| 219 | 499x |
grobs <- list() |
| 220 | ||
| 221 | 499x |
for (i in seq_len(m)) {
|
| 222 | 2169x |
from_idx <- edges$from[i] |
| 223 | 2169x |
to_idx <- edges$to[i] |
| 224 | ||
| 225 | 2169x |
x1 <- nodes$x[from_idx] |
| 226 | 2169x |
y1 <- nodes$y[from_idx] |
| 227 | 2169x |
x2 <- nodes$x[to_idx] |
| 228 | 2169x |
y2 <- nodes$y[to_idx] |
| 229 | ||
| 230 |
# Adjust color with alpha |
|
| 231 | 2169x |
edge_col <- adjust_alpha(colors[i], alphas[i]) |
| 232 | ||
| 233 |
# Line type |
|
| 234 | 2169x |
lty <- switch(styles[i], |
| 235 | 2169x |
solid = 1, |
| 236 | 2169x |
dashed = 2, |
| 237 | 2169x |
dotted = 3, |
| 238 | 2169x |
longdash = 5, |
| 239 | 2169x |
twodash = 6, |
| 240 | 2169x |
1 |
| 241 |
) |
|
| 242 | ||
| 243 |
# Adjust line width for dotted style (reduce by 30% to avoid overly thick appearance) |
|
| 244 | 2169x |
cur_width <- widths[i] |
| 245 | 2169x |
if (lty == 3) { # dotted
|
| 246 | 14x |
cur_width <- cur_width * 0.7 |
| 247 |
} |
|
| 248 | ||
| 249 |
# Handle self-loops |
|
| 250 | 2169x |
if (from_idx == to_idx) {
|
| 251 |
# PASS 1: Draw CI underlay for self-loop (if edge_ci provided) |
|
| 252 | 8x |
if (!is.null(edge_ci) && !is.na(edge_ci[i]) && edge_ci[i] > 0) {
|
| 253 | 2x |
underlay_width <- cur_width * (1 + edge_ci[i] * edge_ci_scale) |
| 254 | 2x |
underlay_col <- if (!is.null(edge_ci_color)) edge_ci_color[i] else colors[i] |
| 255 | 2x |
underlay_col <- adjust_alpha(underlay_col, edge_ci_alpha) |
| 256 | 2x |
underlay_lty <- edge_ci_style |
| 257 | ||
| 258 | 2x |
grobs[[length(grobs) + 1]] <- draw_self_loop( |
| 259 | 2x |
x1, y1, node_sizes[from_idx], underlay_col, underlay_width, underlay_lty, |
| 260 | 2x |
rotation = loop_rotations[i] |
| 261 |
) |
|
| 262 |
} |
|
| 263 | ||
| 264 |
# PASS 2: Draw main self-loop |
|
| 265 | 8x |
grobs[[length(grobs) + 1]] <- draw_self_loop( |
| 266 | 8x |
x1, y1, node_sizes[from_idx], edge_col, cur_width, lty, |
| 267 | 8x |
rotation = loop_rotations[i] |
| 268 |
) |
|
| 269 | 8x |
next |
| 270 |
} |
|
| 271 | ||
| 272 |
# Calculate endpoints (offset by node radius, with aspect correction) |
|
| 273 | 2161x |
start_pt <- edge_endpoint(x1, y1, x2, y2, node_sizes[from_idx], |
| 274 | 2161x |
x_scale = x_scale, y_scale = y_scale) |
| 275 | 2161x |
end_pt <- edge_endpoint(x2, y2, x1, y1, node_sizes[to_idx], |
| 276 | 2161x |
x_scale = x_scale, y_scale = y_scale) |
| 277 | ||
| 278 |
# PASS 1: Draw CI underlay (if edge_ci provided) |
|
| 279 | 2161x |
if (!is.null(edge_ci) && !is.na(edge_ci[i]) && edge_ci[i] > 0) {
|
| 280 | 25x |
underlay_width <- cur_width * (1 + edge_ci[i] * edge_ci_scale) |
| 281 | 25x |
underlay_col <- if (!is.null(edge_ci_color)) edge_ci_color[i] else colors[i] |
| 282 | 25x |
underlay_col <- adjust_alpha(underlay_col, edge_ci_alpha) |
| 283 | 25x |
underlay_lty <- edge_ci_style |
| 284 | ||
| 285 | 25x |
if (curvatures[i] != 0) {
|
| 286 | 12x |
grobs[[length(grobs) + 1]] <- draw_curved_edge( |
| 287 | 12x |
start_pt$x, start_pt$y, end_pt$x, end_pt$y, |
| 288 | 12x |
curvatures[i], underlay_col, underlay_width, underlay_lty, |
| 289 | 12x |
edge_ci_arrows, arrow_size, FALSE, |
| 290 | 12x |
curve_shapes[i], curve_pivots[i], |
| 291 | 12x |
x_scale = x_scale, y_scale = y_scale |
| 292 |
) |
|
| 293 |
} else {
|
|
| 294 | 13x |
grobs[[length(grobs) + 1]] <- draw_straight_edge( |
| 295 | 13x |
start_pt$x, start_pt$y, end_pt$x, end_pt$y, |
| 296 | 13x |
underlay_col, underlay_width, underlay_lty, edge_ci_arrows, arrow_size, |
| 297 | 13x |
FALSE, |
| 298 | 13x |
x_scale = x_scale, y_scale = y_scale |
| 299 |
) |
|
| 300 |
} |
|
| 301 |
} |
|
| 302 | ||
| 303 |
# PASS 2: Draw main edge |
|
| 304 | 2161x |
if (curvatures[i] != 0) {
|
| 305 |
# Curved edge |
|
| 306 | 213x |
grobs[[length(grobs) + 1]] <- draw_curved_edge( |
| 307 | 213x |
start_pt$x, start_pt$y, end_pt$x, end_pt$y, |
| 308 | 213x |
curvatures[i], edge_col, cur_width, lty, |
| 309 | 213x |
show_arrows, arrow_size, bidirectionals[i], |
| 310 | 213x |
curve_shapes[i], curve_pivots[i], |
| 311 | 213x |
x_scale = x_scale, y_scale = y_scale |
| 312 |
) |
|
| 313 |
} else {
|
|
| 314 |
# Straight edge |
|
| 315 | 1948x |
grobs[[length(grobs) + 1]] <- draw_straight_edge( |
| 316 | 1948x |
start_pt$x, start_pt$y, end_pt$x, end_pt$y, |
| 317 | 1948x |
edge_col, cur_width, lty, show_arrows, arrow_size, |
| 318 | 1948x |
bidirectionals[i], |
| 319 | 1948x |
x_scale = x_scale, y_scale = y_scale |
| 320 |
) |
|
| 321 |
} |
|
| 322 |
} |
|
| 323 | ||
| 324 | 499x |
do.call(grid::gList, grobs) |
| 325 |
} |
|
| 326 | ||
| 327 |
#' Draw Straight Edge |
|
| 328 |
#' @keywords internal |
|
| 329 |
draw_straight_edge <- function(x1, y1, x2, y2, color, width, lty, |
|
| 330 |
show_arrow, arrow_size, bidirectional = FALSE, |
|
| 331 |
x_scale = 1, y_scale = 1) {
|
|
| 332 | 1961x |
grobs <- list() |
| 333 | ||
| 334 |
# Calculate angle with aspect correction |
|
| 335 | 1961x |
dx <- (x2 - x1) / x_scale |
| 336 | 1961x |
dy <- (y2 - y1) / y_scale |
| 337 | 1961x |
angle <- atan2(dy, dx) |
| 338 | ||
| 339 |
# Draw line from start to end (arrow overlays the end) |
|
| 340 | 1961x |
grobs[[1]] <- grid::segmentsGrob( |
| 341 | 1961x |
x0 = grid::unit(x1, "npc"), |
| 342 | 1961x |
y0 = grid::unit(y1, "npc"), |
| 343 | 1961x |
x1 = grid::unit(x2, "npc"), |
| 344 | 1961x |
y1 = grid::unit(y2, "npc"), |
| 345 | 1961x |
gp = grid::gpar(col = color, lwd = width, lty = lty) |
| 346 |
) |
|
| 347 | ||
| 348 |
# Draw arrow at target (tip at endpoint) |
|
| 349 | 1961x |
if (show_arrow && arrow_size > 0) {
|
| 350 | 89x |
arrow_pts <- arrow_points(x2, y2, angle, arrow_size, |
| 351 | 89x |
x_scale = x_scale, y_scale = y_scale) |
| 352 | 89x |
grobs[[2]] <- grid::polygonGrob( |
| 353 | 89x |
x = grid::unit(arrow_pts$x, "npc"), |
| 354 | 89x |
y = grid::unit(arrow_pts$y, "npc"), |
| 355 | 89x |
gp = grid::gpar(fill = color, col = color) |
| 356 |
) |
|
| 357 |
} |
|
| 358 | ||
| 359 |
# Draw arrow at source if bidirectional (tip at start point) |
|
| 360 | 1961x |
if (bidirectional && arrow_size > 0) {
|
| 361 | 10x |
dx_back <- (x1 - x2) / x_scale |
| 362 | 10x |
dy_back <- (y1 - y2) / y_scale |
| 363 | 10x |
angle_back <- atan2(dy_back, dx_back) |
| 364 | 10x |
arrow_pts_back <- arrow_points(x1, y1, angle_back, arrow_size, |
| 365 | 10x |
x_scale = x_scale, y_scale = y_scale) |
| 366 | 10x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 367 | 10x |
x = grid::unit(arrow_pts_back$x, "npc"), |
| 368 | 10x |
y = grid::unit(arrow_pts_back$y, "npc"), |
| 369 | 10x |
gp = grid::gpar(fill = color, col = color) |
| 370 |
) |
|
| 371 |
} |
|
| 372 | ||
| 373 | 1961x |
do.call(grid::gList, grobs) |
| 374 |
} |
|
| 375 | ||
| 376 |
#' Draw Curved Edge |
|
| 377 |
#' @keywords internal |
|
| 378 |
draw_curved_edge <- function(x1, y1, x2, y2, curvature, color, width, lty, |
|
| 379 |
show_arrow, arrow_size, bidirectional = FALSE, |
|
| 380 |
curve_shape = 0, curve_pivot = 0.5, |
|
| 381 |
x_scale = 1, y_scale = 1) {
|
|
| 382 | 225x |
grobs <- list() |
| 383 | ||
| 384 |
# Calculate control point with shape and pivot adjustments |
|
| 385 | 225x |
ctrl <- curve_control_point(x1, y1, x2, y2, curvature, |
| 386 | 225x |
pivot = curve_pivot, shape = curve_shape) |
| 387 | ||
| 388 |
# Generate bezier points |
|
| 389 | 225x |
pts <- bezier_points(x1, y1, ctrl$x, ctrl$y, x2, y2, n = 50) |
| 390 | 225x |
n <- nrow(pts) |
| 391 | ||
| 392 |
# Draw curve (arrows overlay the ends) |
|
| 393 | 225x |
grobs[[1]] <- grid::linesGrob( |
| 394 | 225x |
x = grid::unit(pts$x, "npc"), |
| 395 | 225x |
y = grid::unit(pts$y, "npc"), |
| 396 | 225x |
gp = grid::gpar(col = color, lwd = width, lty = lty) |
| 397 |
) |
|
| 398 | ||
| 399 |
# Draw arrow at target (tip at curve end, angle follows curve direction) |
|
| 400 | 225x |
if (show_arrow && arrow_size > 0) {
|
| 401 |
# Calculate angle with aspect correction |
|
| 402 | 173x |
dx <- (pts$x[n] - pts$x[n-1]) / x_scale |
| 403 | 173x |
dy <- (pts$y[n] - pts$y[n-1]) / y_scale |
| 404 | 173x |
angle <- atan2(dy, dx) |
| 405 | 173x |
arrow_pts <- arrow_points(x2, y2, angle, arrow_size, |
| 406 | 173x |
x_scale = x_scale, y_scale = y_scale) |
| 407 | 173x |
grobs[[2]] <- grid::polygonGrob( |
| 408 | 173x |
x = grid::unit(arrow_pts$x, "npc"), |
| 409 | 173x |
y = grid::unit(arrow_pts$y, "npc"), |
| 410 | 173x |
gp = grid::gpar(fill = color, col = color) |
| 411 |
) |
|
| 412 |
} |
|
| 413 | ||
| 414 |
# Draw arrow at source if bidirectional |
|
| 415 | 225x |
if (bidirectional && arrow_size > 0) {
|
| 416 | 5x |
dx_back <- (pts$x[1] - pts$x[2]) / x_scale |
| 417 | 5x |
dy_back <- (pts$y[1] - pts$y[2]) / y_scale |
| 418 | 5x |
angle_back <- atan2(dy_back, dx_back) |
| 419 | 5x |
arrow_pts_back <- arrow_points(x1, y1, angle_back, arrow_size, |
| 420 | 5x |
x_scale = x_scale, y_scale = y_scale) |
| 421 | 5x |
grobs[[length(grobs) + 1]] <- grid::polygonGrob( |
| 422 | 5x |
x = grid::unit(arrow_pts_back$x, "npc"), |
| 423 | 5x |
y = grid::unit(arrow_pts_back$y, "npc"), |
| 424 | 5x |
gp = grid::gpar(fill = color, col = color) |
| 425 |
) |
|
| 426 |
} |
|
| 427 | ||
| 428 | 225x |
do.call(grid::gList, grobs) |
| 429 |
} |
|
| 430 | ||
| 431 |
#' Draw Self-Loop |
|
| 432 |
#' @param x,y Node center coordinates. |
|
| 433 |
#' @param node_size Node radius. |
|
| 434 |
#' @param color Loop color. |
|
| 435 |
#' @param width Loop line width. |
|
| 436 |
#' @param lty Loop line type. |
|
| 437 |
#' @param rotation Angle in radians for loop direction (default: pi/2 = top). |
|
| 438 |
#' @keywords internal |
|
| 439 |
draw_self_loop <- function(x, y, node_size, color, width, lty, rotation = pi/2) {
|
|
| 440 |
# Get aspect ratio correction |
|
| 441 | 10x |
vp_width <- grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 442 | 10x |
vp_height <- grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE) |
| 443 | 10x |
min_dim <- min(vp_width, vp_height) |
| 444 | 10x |
x_scale <- min_dim / vp_width |
| 445 | 10x |
y_scale <- min_dim / vp_height |
| 446 | ||
| 447 |
# Loop parameters |
|
| 448 | 10x |
loop_angle <- pi/8 # Angle spread for loop attachment points |
| 449 |
# rotation is now a parameter (default: pi/2 = top of node) |
|
| 450 | ||
| 451 |
# Points where loop attaches to node edge |
|
| 452 | 10x |
left_angle <- rotation + loop_angle |
| 453 | 10x |
right_angle <- rotation - loop_angle |
| 454 | ||
| 455 | 10x |
left_x <- x + (node_size * x_scale) * cos(left_angle) |
| 456 | 10x |
left_y <- y + (node_size * y_scale) * sin(left_angle) |
| 457 | ||
| 458 | 10x |
right_x <- x + (node_size * x_scale) * cos(right_angle) |
| 459 | 10x |
right_y <- y + (node_size * y_scale) * sin(right_angle) |
| 460 | ||
| 461 |
# Loop center point (outside the node) - larger = further out |
|
| 462 | 10x |
loop_dist <- node_size * 2.2 |
| 463 | 10x |
center_x <- x + (loop_dist * x_scale) * cos(rotation) |
| 464 | 10x |
center_y <- y + (loop_dist * y_scale) * sin(rotation) |
| 465 | ||
| 466 |
# Create smooth bezier-like curve through control points |
|
| 467 |
# Control points for the loop |
|
| 468 | 10x |
ctrl1_x <- left_x + (loop_dist * 0.8 * x_scale) * cos(rotation + pi/6) |
| 469 | 10x |
ctrl1_y <- left_y + (loop_dist * 0.8 * y_scale) * sin(rotation + pi/6) |
| 470 | ||
| 471 | 10x |
ctrl2_x <- right_x + (loop_dist * 0.8 * x_scale) * cos(rotation - pi/6) |
| 472 | 10x |
ctrl2_y <- right_y + (loop_dist * 0.8 * y_scale) * sin(rotation - pi/6) |
| 473 | ||
| 474 |
# Generate smooth curve using bezier-like interpolation |
|
| 475 | 10x |
t_vals <- seq(0, 1, length.out = 40) |
| 476 | 10x |
curve_x <- numeric(length(t_vals)) |
| 477 | 10x |
curve_y <- numeric(length(t_vals)) |
| 478 | ||
| 479 | 10x |
for (i in seq_along(t_vals)) {
|
| 480 | 400x |
t <- t_vals[i] |
| 481 |
# Cubic bezier formula |
|
| 482 | 400x |
curve_x[i] <- (1-t)^3 * left_x + 3*(1-t)^2*t * ctrl1_x + |
| 483 | 400x |
3*(1-t)*t^2 * ctrl2_x + t^3 * right_x |
| 484 | 400x |
curve_y[i] <- (1-t)^3 * left_y + 3*(1-t)^2*t * ctrl1_y + |
| 485 | 400x |
3*(1-t)*t^2 * ctrl2_y + t^3 * right_y |
| 486 |
} |
|
| 487 | ||
| 488 | 10x |
grobs <- list() |
| 489 | ||
| 490 |
# Draw the loop curve |
|
| 491 | 10x |
grobs[[1]] <- grid::linesGrob( |
| 492 | 10x |
x = grid::unit(curve_x, "npc"), |
| 493 | 10x |
y = grid::unit(curve_y, "npc"), |
| 494 | 10x |
gp = grid::gpar(col = color, lwd = width, lty = lty) |
| 495 |
) |
|
| 496 | ||
| 497 |
# Add arrowhead at the end (pointing into node) |
|
| 498 | 10x |
n <- length(curve_x) |
| 499 | 10x |
grobs[[2]] <- grid::linesGrob( |
| 500 | 10x |
x = grid::unit(curve_x[(n-3):n], "npc"), |
| 501 | 10x |
y = grid::unit(curve_y[(n-3):n], "npc"), |
| 502 | 10x |
arrow = grid::arrow(length = grid::unit(0.08, "inches"), type = "closed"), |
| 503 | 10x |
gp = grid::gpar(col = color, lwd = width, fill = color) |
| 504 |
) |
|
| 505 | ||
| 506 | 10x |
do.call(grid::gList, grobs) |
| 507 |
} |
|
| 508 | ||
| 509 |
#' Render Edge Labels |
|
| 510 |
#' |
|
| 511 |
#' Create grid grobs for edge labels with background, borders, and styling. |
|
| 512 |
#' |
|
| 513 |
#' @param network A CographNetwork object. |
|
| 514 |
#' @return A grid gList of label grobs. |
|
| 515 |
#' @keywords internal |
|
| 516 |
render_edge_labels_grid <- function(network) {
|
|
| 517 | 509x |
nodes <- network$get_nodes() |
| 518 | 509x |
edges <- network$get_edges() |
| 519 | 509x |
aes <- network$get_edge_aes() |
| 520 | 509x |
theme <- network$get_theme() |
| 521 | ||
| 522 | 11x |
if (is.null(edges) || nrow(edges) == 0) return(grid::gList()) |
| 523 | ||
| 524 | 498x |
m <- nrow(edges) |
| 525 | ||
| 526 |
# Check for template-based labels first |
|
| 527 | 498x |
has_template <- !is.null(aes$label_template) || |
| 528 | 498x |
(!is.null(aes$label_style) && aes$label_style != "none") |
| 529 | ||
| 530 | 498x |
if (has_template) {
|
| 531 |
# Use template-based labels |
|
| 532 | 6x |
edge_weights <- if ("weight" %in% names(edges)) edges$weight else NULL
|
| 533 | 6x |
labels <- build_edge_labels_from_template( |
| 534 | 6x |
template = aes$label_template, |
| 535 | 6x |
style = if (!is.null(aes$label_style)) aes$label_style else "none", |
| 536 | 6x |
weights = edge_weights, |
| 537 | 6x |
ci_lower = aes$ci_lower, |
| 538 | 6x |
ci_upper = aes$ci_upper, |
| 539 | 6x |
p_values = aes$label_p, |
| 540 | 6x |
stars = aes$label_stars, |
| 541 | 6x |
digits = if (!is.null(aes$label_digits)) aes$label_digits else 2, |
| 542 | 6x |
p_digits = if (!is.null(aes$label_p_digits)) aes$label_p_digits else 3, |
| 543 | 6x |
p_prefix = if (!is.null(aes$label_p_prefix)) aes$label_p_prefix else "p=", |
| 544 | 6x |
ci_format = if (!is.null(aes$label_ci_format)) aes$label_ci_format else "bracket", |
| 545 | 6x |
oneline = TRUE, |
| 546 | 6x |
n = m |
| 547 |
) |
|
| 548 | 492x |
} else if (!is.null(aes$labels)) {
|
| 549 |
# Use standard labels |
|
| 550 | 39x |
labels <- recycle_to_length(aes$labels, m) |
| 551 |
} else {
|
|
| 552 | 453x |
return(grid::gList()) |
| 553 |
} |
|
| 554 | ||
| 555 | 1x |
if (is.null(labels)) return(grid::gList()) |
| 556 | ||
| 557 |
# Vectorize edge label parameters (strict: length 1 or m) |
|
| 558 | 44x |
label_sizes <- expand_param( |
| 559 | 44x |
if (!is.null(aes$label_size)) aes$label_size else 8, |
| 560 | 44x |
m, "edge_label_size" |
| 561 |
) |
|
| 562 | 44x |
label_colors <- expand_param( |
| 563 | 44x |
if (!is.null(aes$label_color)) aes$label_color else "gray30", |
| 564 | 44x |
m, "edge_label_color" |
| 565 |
) |
|
| 566 | ||
| 567 |
# Label position along edge (0 = at source, 0.5 = midpoint, 1 = at target) |
|
| 568 |
# Default 0.65 = slightly closer to target (strict vectorization) |
|
| 569 | 44x |
label_positions <- expand_param( |
| 570 | 44x |
if (!is.null(aes$label_position)) aes$label_position else 0.65, |
| 571 | 44x |
m, "edge_label_position" |
| 572 |
) |
|
| 573 |
# Label offset perpendicular to edge - default 0 (on the edge line) |
|
| 574 | 44x |
label_offsets <- expand_param( |
| 575 | 44x |
if (!is.null(aes$label_offset)) aes$label_offset else 0, |
| 576 | 44x |
m, "edge_label_offset" |
| 577 |
) |
|
| 578 | ||
| 579 |
# New styling options - vectorize (strict) |
|
| 580 | 44x |
label_bgs <- expand_param( |
| 581 | 44x |
if (!is.null(aes$label_bg)) aes$label_bg else "white", |
| 582 | 44x |
m, "edge_label_bg" |
| 583 |
) |
|
| 584 | 44x |
label_bg_padding <- if (!is.null(aes$label_bg_padding)) aes$label_bg_padding else 0.3 |
| 585 | ||
| 586 |
# Vectorize fontface with string-to-number conversion (strict) |
|
| 587 | 44x |
label_fontface_raw <- expand_param( |
| 588 | 44x |
if (!is.null(aes$label_fontface)) aes$label_fontface else "plain", |
| 589 | 44x |
m, "edge_label_fontface" |
| 590 |
) |
|
| 591 | 44x |
label_fontfaces <- sapply(label_fontface_raw, function(ff) {
|
| 592 | 121x |
if (is.character(ff)) {
|
| 593 | 119x |
switch(ff, |
| 594 | 103x |
"plain" = 1, |
| 595 | 4x |
"bold" = 2, |
| 596 | 2x |
"italic" = 3, |
| 597 | 8x |
"bold.italic" = 4, |
| 598 | 2x |
1 # default |
| 599 |
) |
|
| 600 |
} else {
|
|
| 601 | 2x |
ff |
| 602 |
} |
|
| 603 |
}) |
|
| 604 | 44x |
label_border <- aes$label_border # NULL, "rect", "rounded", "circle" |
| 605 | 44x |
label_border_color <- if (!is.null(aes$label_border_color)) aes$label_border_color else "gray50" |
| 606 | 44x |
label_underline <- if (!is.null(aes$label_underline)) aes$label_underline else FALSE |
| 607 | ||
| 608 |
# Shadow options (strict vectorization) |
|
| 609 | 44x |
label_shadows <- expand_param( |
| 610 | 44x |
if (!is.null(aes$label_shadow)) aes$label_shadow else FALSE, |
| 611 | 44x |
m, "edge_label_shadow" |
| 612 |
) |
|
| 613 | 44x |
label_shadow_colors <- expand_param( |
| 614 | 44x |
if (!is.null(aes$label_shadow_color)) aes$label_shadow_color else "gray40", |
| 615 | 44x |
m, "edge_label_shadow_color" |
| 616 |
) |
|
| 617 | 44x |
label_shadow_offsets <- expand_param( |
| 618 | 44x |
if (!is.null(aes$label_shadow_offset)) aes$label_shadow_offset else 0.5, |
| 619 | 44x |
m, "edge_label_shadow_offset" |
| 620 |
) |
|
| 621 | 44x |
label_shadow_alphas <- expand_param( |
| 622 | 44x |
if (!is.null(aes$label_shadow_alpha)) aes$label_shadow_alpha else 0.5, |
| 623 | 44x |
m, "edge_label_shadow_alpha" |
| 624 |
) |
|
| 625 | ||
| 626 |
# Get curvature for positioning |
|
| 627 | 44x |
curvatures <- recycle_to_length( |
| 628 | 44x |
if (!is.null(aes$curvature)) aes$curvature else 0, |
| 629 | 44x |
m |
| 630 |
) |
|
| 631 | ||
| 632 |
# Get curves mode and apply same logic as render_edges_grid |
|
| 633 |
# TRUE (default) = reciprocal edges curve as ellipse, singles straight |
|
| 634 |
# FALSE = all straight; "force" = all curved |
|
| 635 | 44x |
curves_mode <- if (!is.null(aes$curves)) aes$curves else TRUE |
| 636 | ||
| 637 | 44x |
if (!identical(curves_mode, FALSE)) {
|
| 638 |
# Identify reciprocal pairs |
|
| 639 | 43x |
is_reciprocal <- rep(FALSE, m) |
| 640 | 43x |
for (i in seq_len(m)) {
|
| 641 | 119x |
from_i <- edges$from[i] |
| 642 | 119x |
to_i <- edges$to[i] |
| 643 | 7x |
if (from_i == to_i) next |
| 644 | 112x |
for (j in seq_len(m)) {
|
| 645 | 314x |
if (j != i && edges$from[j] == to_i && edges$to[j] == from_i) {
|
| 646 | 30x |
is_reciprocal[i] <- TRUE |
| 647 | 30x |
break |
| 648 |
} |
|
| 649 |
} |
|
| 650 |
} |
|
| 651 | ||
| 652 |
# Curve reciprocal edges with direction based on network center (qgraph-style) |
|
| 653 | 43x |
default_curve <- 0.25 |
| 654 | ||
| 655 |
# Calculate network center for curve direction |
|
| 656 | 43x |
center_x <- mean(nodes$x) |
| 657 | 43x |
center_y <- mean(nodes$y) |
| 658 | ||
| 659 | 43x |
for (i in seq_len(m)) {
|
| 660 | 119x |
if (is_reciprocal[i] && curvatures[i] == 0) {
|
| 661 | 30x |
from_i <- edges$from[i] |
| 662 | 30x |
to_i <- edges$to[i] |
| 663 | ||
| 664 |
# Calculate edge midpoint |
|
| 665 | 30x |
mid_x <- (nodes$x[from_i] + nodes$x[to_i]) / 2 |
| 666 | 30x |
mid_y <- (nodes$y[from_i] + nodes$y[to_i]) / 2 |
| 667 | ||
| 668 |
# Calculate perpendicular direction (for curve) |
|
| 669 | 30x |
dx <- nodes$x[to_i] - nodes$x[from_i] |
| 670 | 30x |
dy <- nodes$y[to_i] - nodes$y[from_i] |
| 671 | ||
| 672 |
# Perpendicular vector (rotated 90 degrees) |
|
| 673 | 30x |
perp_x <- -dy |
| 674 | 30x |
perp_y <- dx |
| 675 | ||
| 676 |
# Check if positive curve moves toward or away from center |
|
| 677 | 30x |
test_x <- mid_x + perp_x * 0.1 |
| 678 | 30x |
test_y <- mid_y + perp_y * 0.1 |
| 679 | 30x |
dist_to_center_pos <- sqrt((test_x - center_x)^2 + (test_y - center_y)^2) |
| 680 | 30x |
dist_to_center_orig <- sqrt((mid_x - center_x)^2 + (mid_y - center_y)^2) |
| 681 | ||
| 682 |
# Both edges curve OUTWARD (away from center), on opposite sides |
|
| 683 | 30x |
curvatures[i] <- if (dist_to_center_pos > dist_to_center_orig) default_curve else -default_curve |
| 684 |
} |
|
| 685 |
} |
|
| 686 | ||
| 687 |
# For "force" mode, also curve non-reciprocal edges |
|
| 688 | 43x |
if (identical(curves_mode, "force")) {
|
| 689 | 3x |
for (i in seq_len(m)) {
|
| 690 | 8x |
from_i <- edges$from[i] |
| 691 | 8x |
to_i <- edges$to[i] |
| 692 | 2x |
if (is_reciprocal[i] || from_i == to_i) next |
| 693 | 6x |
if (curvatures[i] == 0) {
|
| 694 | 6x |
curvatures[i] <- default_curve |
| 695 |
} |
|
| 696 |
} |
|
| 697 |
} |
|
| 698 |
} |
|
| 699 | ||
| 700 |
# Get curve pivot for label positioning on curves |
|
| 701 | 44x |
curve_pivots <- recycle_to_length( |
| 702 | 44x |
if (!is.null(aes$curve_pivot)) aes$curve_pivot else 0.5, |
| 703 | 44x |
m |
| 704 |
) |
|
| 705 | ||
| 706 |
# Get node sizes for edge endpoint calculation |
|
| 707 | 44x |
node_aes <- network$get_node_aes() |
| 708 | 44x |
node_sizes <- recycle_to_length( |
| 709 | 44x |
if (!is.null(node_aes$size)) node_aes$size else 0.05, |
| 710 | 44x |
nrow(nodes) |
| 711 |
) |
|
| 712 | ||
| 713 | 44x |
grobs <- vector("list", m)
|
| 714 | 44x |
for (i in seq_len(m)) {
|
| 715 | 121x |
from_idx <- edges$from[i] |
| 716 | 121x |
to_idx <- edges$to[i] |
| 717 | ||
| 718 |
# Skip self-loops for labels (would need special handling) |
|
| 719 | 121x |
if (from_idx == to_idx) {
|
| 720 | 7x |
grobs[[i]] <- grid::nullGrob() |
| 721 | 7x |
next |
| 722 |
} |
|
| 723 | ||
| 724 |
# Use actual edge endpoints (same as edge rendering) |
|
| 725 | 114x |
node_x1 <- nodes$x[from_idx] |
| 726 | 114x |
node_y1 <- nodes$y[from_idx] |
| 727 | 114x |
node_x2 <- nodes$x[to_idx] |
| 728 | 114x |
node_y2 <- nodes$y[to_idx] |
| 729 | ||
| 730 | 114x |
start_pt <- edge_endpoint(node_x1, node_y1, node_x2, node_y2, node_sizes[from_idx]) |
| 731 | 114x |
end_pt <- edge_endpoint(node_x2, node_y2, node_x1, node_y1, node_sizes[to_idx]) |
| 732 | ||
| 733 | 114x |
x1 <- start_pt$x |
| 734 | 114x |
y1 <- start_pt$y |
| 735 | 114x |
x2 <- end_pt$x |
| 736 | 114x |
y2 <- end_pt$y |
| 737 | ||
| 738 |
# Position along edge (per-edge value from vectorized label_positions) |
|
| 739 | 114x |
pos <- label_positions[i] |
| 740 | ||
| 741 |
# Calculate perpendicular direction |
|
| 742 | 114x |
dx <- x2 - x1 |
| 743 | 114x |
dy <- y2 - y1 |
| 744 | 114x |
len <- sqrt(dx^2 + dy^2) |
| 745 | ||
| 746 | 114x |
if (len == 0) {
|
| 747 | 1x |
grobs[[i]] <- grid::nullGrob() |
| 748 | 1x |
next |
| 749 |
} |
|
| 750 | ||
| 751 |
# Perpendicular unit vector (rotated 90 degrees) |
|
| 752 | 113x |
perp_x <- -dy / len |
| 753 | 113x |
perp_y <- dx / len |
| 754 | ||
| 755 |
# If edge is curved, position label along the curve |
|
| 756 | 113x |
curv <- curvatures[i] |
| 757 | 113x |
if (curv != 0) {
|
| 758 |
# Get control point |
|
| 759 | 44x |
pivot <- curve_pivots[i] |
| 760 | 44x |
ctrl <- curve_control_point(x1, y1, x2, y2, curv, pivot = pivot, shape = 0) |
| 761 | ||
| 762 |
# Position along bezier curve at 'pos' |
|
| 763 | 44x |
t <- pos |
| 764 |
# Quadratic bezier formula |
|
| 765 | 44x |
x <- (1 - t)^2 * x1 + 2 * (1 - t) * t * ctrl$x + t^2 * x2 |
| 766 | 44x |
y <- (1 - t)^2 * y1 + 2 * (1 - t) * t * ctrl$y + t^2 * y2 |
| 767 |
} else {
|
|
| 768 |
# Straight edge |
|
| 769 | 69x |
x <- x1 + pos * (x2 - x1) |
| 770 | 69x |
y <- y1 + pos * (y2 - y1) |
| 771 |
} |
|
| 772 | ||
| 773 |
# Apply user-specified offset (per-edge value from vectorized label_offsets) |
|
| 774 | 113x |
offset <- label_offsets[i] |
| 775 | 113x |
if (offset != 0) {
|
| 776 | 4x |
x <- x + offset * perp_x |
| 777 | 4x |
y <- y + offset * perp_y |
| 778 |
} |
|
| 779 | ||
| 780 |
# Create label grob with styling |
|
| 781 | 113x |
label_grobs <- list() |
| 782 | ||
| 783 |
# Calculate text dimensions for background/border |
|
| 784 |
# Get per-edge label styling |
|
| 785 | 113x |
cur_label_size <- label_sizes[i] |
| 786 | 113x |
cur_label_color <- label_colors[i] |
| 787 | 113x |
cur_label_bg <- label_bgs[i] |
| 788 | 113x |
cur_fontface_num <- label_fontfaces[i] |
| 789 | ||
| 790 | 113x |
text_width <- grid::convertWidth( |
| 791 | 113x |
grid::stringWidth(as.character(labels[i])), |
| 792 | 113x |
"npc", valueOnly = TRUE |
| 793 | 113x |
) * (cur_label_size / 12) # Scale by font size (smaller) |
| 794 | 113x |
text_height <- grid::convertHeight( |
| 795 | 113x |
grid::stringHeight(as.character(labels[i])), |
| 796 | 113x |
"npc", valueOnly = TRUE |
| 797 | 113x |
) * (cur_label_size / 12) |
| 798 | ||
| 799 |
# Add padding (smaller halo) |
|
| 800 | 113x |
pad_w <- text_width * label_bg_padding * 0.5 |
| 801 | 113x |
pad_h <- text_height * label_bg_padding * 0.5 |
| 802 | 113x |
bg_width <- text_width + pad_w * 2 |
| 803 | 113x |
bg_height <- text_height + pad_h * 2 |
| 804 | ||
| 805 |
# Draw background (white by default) |
|
| 806 | 113x |
if (!is.na(cur_label_bg) && !is.null(cur_label_bg)) {
|
| 807 | 109x |
if (!is.null(label_border) && label_border == "circle") {
|
| 808 |
# Circle background (tight fit) |
|
| 809 | 4x |
radius <- max(bg_width, bg_height) / 2 * 0.9 |
| 810 | 4x |
label_grobs[[length(label_grobs) + 1]] <- grid::circleGrob( |
| 811 | 4x |
x = grid::unit(x, "npc"), |
| 812 | 4x |
y = grid::unit(y, "npc"), |
| 813 | 4x |
r = grid::unit(radius, "npc"), |
| 814 | 4x |
gp = grid::gpar(fill = cur_label_bg, col = label_border_color, lwd = 0.5) |
| 815 |
) |
|
| 816 | 105x |
} else if (!is.null(label_border) && label_border == "rounded") {
|
| 817 |
# Rounded rectangle background (tight fit) |
|
| 818 | 4x |
label_grobs[[length(label_grobs) + 1]] <- grid::roundrectGrob( |
| 819 | 4x |
x = grid::unit(x, "npc"), |
| 820 | 4x |
y = grid::unit(y, "npc"), |
| 821 | 4x |
width = grid::unit(bg_width * 1.1, "npc"), |
| 822 | 4x |
height = grid::unit(bg_height * 1.2, "npc"), |
| 823 | 4x |
r = grid::unit(0.2, "npc"), |
| 824 | 4x |
gp = grid::gpar(fill = cur_label_bg, col = label_border_color, lwd = 0.5) |
| 825 |
) |
|
| 826 |
} else {
|
|
| 827 |
# Rectangle background (tight fit, default) |
|
| 828 | 101x |
border_col <- if (!is.null(label_border) && label_border == "rect") label_border_color else NA |
| 829 | 101x |
label_grobs[[length(label_grobs) + 1]] <- grid::rectGrob( |
| 830 | 101x |
x = grid::unit(x, "npc"), |
| 831 | 101x |
y = grid::unit(y, "npc"), |
| 832 | 101x |
width = grid::unit(bg_width * 1.1, "npc"), |
| 833 | 101x |
height = grid::unit(bg_height * 1.2, "npc"), |
| 834 | 101x |
gp = grid::gpar(fill = cur_label_bg, col = border_col, lwd = 0.5) |
| 835 |
) |
|
| 836 |
} |
|
| 837 |
} |
|
| 838 | ||
| 839 |
# Draw shadow text first (if enabled) - per-edge shadow settings |
|
| 840 | 113x |
if (label_shadows[i]) {
|
| 841 |
# Calculate shadow offset in NPC units (points to NPC conversion) |
|
| 842 | 7x |
shadow_offset_npc <- label_shadow_offsets[i] * 0.002 |
| 843 | 7x |
shadow_col <- adjust_alpha(label_shadow_colors[i], label_shadow_alphas[i]) |
| 844 | ||
| 845 | 7x |
label_grobs[[length(label_grobs) + 1]] <- grid::textGrob( |
| 846 | 7x |
label = labels[i], |
| 847 | 7x |
x = grid::unit(x + shadow_offset_npc, "npc"), |
| 848 | 7x |
y = grid::unit(y - shadow_offset_npc, "npc"), |
| 849 | 7x |
gp = grid::gpar(fontsize = cur_label_size, col = shadow_col, fontface = cur_fontface_num) |
| 850 |
) |
|
| 851 |
} |
|
| 852 | ||
| 853 |
# Draw main text |
|
| 854 | 113x |
label_grobs[[length(label_grobs) + 1]] <- grid::textGrob( |
| 855 | 113x |
label = labels[i], |
| 856 | 113x |
x = grid::unit(x, "npc"), |
| 857 | 113x |
y = grid::unit(y, "npc"), |
| 858 | 113x |
gp = grid::gpar(fontsize = cur_label_size, col = cur_label_color, fontface = cur_fontface_num) |
| 859 |
) |
|
| 860 | ||
| 861 |
# Draw underline if requested |
|
| 862 | 113x |
if (label_underline) {
|
| 863 | 4x |
underline_y <- y - text_height * 0.6 |
| 864 | 4x |
label_grobs[[length(label_grobs) + 1]] <- grid::segmentsGrob( |
| 865 | 4x |
x0 = grid::unit(x - text_width / 2, "npc"), |
| 866 | 4x |
y0 = grid::unit(underline_y, "npc"), |
| 867 | 4x |
x1 = grid::unit(x + text_width / 2, "npc"), |
| 868 | 4x |
y1 = grid::unit(underline_y, "npc"), |
| 869 | 4x |
gp = grid::gpar(col = cur_label_color, lwd = 0.8) |
| 870 |
) |
|
| 871 |
} |
|
| 872 | ||
| 873 | 113x |
grobs[[i]] <- do.call(grid::gList, label_grobs) |
| 874 |
} |
|
| 875 | ||
| 876 | 44x |
do.call(grid::gList, grobs) |
| 877 |
} |
| 1 |
#' @title Base R Polygon Shape Definitions |
|
| 2 |
#' @description Vertex generation functions for polygon-based node shapes. |
|
| 3 |
#' @name splot-polygons |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Generate Circle Vertices |
|
| 8 |
#' |
|
| 9 |
#' @param x Center x coordinate. |
|
| 10 |
#' @param y Center y coordinate. |
|
| 11 |
#' @param r Radius. |
|
| 12 |
#' @param n Number of vertices. |
|
| 13 |
#' @return List with x, y vectors of vertices. |
|
| 14 |
#' @keywords internal |
|
| 15 |
circle_vertices <- function(x, y, r, n = 50) {
|
|
| 16 | 14x |
angles <- seq(0, 2 * pi, length.out = n + 1)[-1] |
| 17 | 14x |
list( |
| 18 | 14x |
x = x + r * cos(angles), |
| 19 | 14x |
y = y + r * sin(angles) |
| 20 |
) |
|
| 21 |
} |
|
| 22 | ||
| 23 |
#' Generate Square Vertices |
|
| 24 |
#' |
|
| 25 |
#' @param x Center x coordinate. |
|
| 26 |
#' @param y Center y coordinate. |
|
| 27 |
#' @param r Half-width (vertex distance from center). |
|
| 28 |
#' @return List with x, y vectors of vertices. |
|
| 29 |
#' @keywords internal |
|
| 30 |
square_vertices <- function(x, y, r) {
|
|
| 31 | 37x |
list( |
| 32 | 37x |
x = x + r * c(-1, 1, 1, -1), |
| 33 | 37x |
y = y + r * c(-1, -1, 1, 1) |
| 34 |
) |
|
| 35 |
} |
|
| 36 | ||
| 37 |
#' Generate Rectangle Vertices |
|
| 38 |
#' |
|
| 39 |
#' @param x Center x coordinate. |
|
| 40 |
#' @param y Center y coordinate. |
|
| 41 |
#' @param w Half-width. |
|
| 42 |
#' @param h Half-height. |
|
| 43 |
#' @return List with x, y vectors of vertices. |
|
| 44 |
#' @keywords internal |
|
| 45 |
rectangle_vertices <- function(x, y, w, h) {
|
|
| 46 | 12x |
list( |
| 47 | 12x |
x = x + w * c(-1, 1, 1, -1), |
| 48 | 12x |
y = y + h * c(-1, -1, 1, 1) |
| 49 |
) |
|
| 50 |
} |
|
| 51 | ||
| 52 |
#' Generate Triangle Vertices |
|
| 53 |
#' |
|
| 54 |
#' @param x Center x coordinate. |
|
| 55 |
#' @param y Center y coordinate. |
|
| 56 |
#' @param r Radius (vertex distance from center). |
|
| 57 |
#' @return List with x, y vectors of vertices. |
|
| 58 |
#' @keywords internal |
|
| 59 |
triangle_vertices <- function(x, y, r) {
|
|
| 60 | 44x |
angles <- c(pi/2, pi/2 + 2*pi/3, pi/2 + 4*pi/3) |
| 61 | 44x |
list( |
| 62 | 44x |
x = x + r * cos(angles), |
| 63 | 44x |
y = y + r * sin(angles) |
| 64 |
) |
|
| 65 |
} |
|
| 66 | ||
| 67 |
#' Generate Diamond Vertices |
|
| 68 |
#' |
|
| 69 |
#' @param x Center x coordinate. |
|
| 70 |
#' @param y Center y coordinate. |
|
| 71 |
#' @param r Radius (vertex distance from center). |
|
| 72 |
#' @return List with x, y vectors of vertices. |
|
| 73 |
#' @keywords internal |
|
| 74 |
diamond_vertices <- function(x, y, r) {
|
|
| 75 | 86x |
angles <- c(0, pi/2, pi, 3*pi/2) |
| 76 | 86x |
list( |
| 77 | 86x |
x = x + r * cos(angles), |
| 78 | 86x |
y = y + r * sin(angles) |
| 79 |
) |
|
| 80 |
} |
|
| 81 | ||
| 82 |
#' Generate Pentagon Vertices |
|
| 83 |
#' |
|
| 84 |
#' @param x Center x coordinate. |
|
| 85 |
#' @param y Center y coordinate. |
|
| 86 |
#' @param r Radius. |
|
| 87 |
#' @return List with x, y vectors of vertices. |
|
| 88 |
#' @keywords internal |
|
| 89 |
pentagon_vertices <- function(x, y, r) {
|
|
| 90 | 20x |
angles <- seq(pi/2, pi/2 + 2*pi * (4/5), length.out = 5) |
| 91 | 20x |
list( |
| 92 | 20x |
x = x + r * cos(angles), |
| 93 | 20x |
y = y + r * sin(angles) |
| 94 |
) |
|
| 95 |
} |
|
| 96 | ||
| 97 |
#' Generate Hexagon Vertices |
|
| 98 |
#' |
|
| 99 |
#' @param x Center x coordinate. |
|
| 100 |
#' @param y Center y coordinate. |
|
| 101 |
#' @param r Radius. |
|
| 102 |
#' @return List with x, y vectors of vertices. |
|
| 103 |
#' @keywords internal |
|
| 104 |
hexagon_vertices <- function(x, y, r) {
|
|
| 105 | 47x |
angles <- seq(0, 2*pi * (5/6), length.out = 6) |
| 106 | 47x |
list( |
| 107 | 47x |
x = x + r * cos(angles), |
| 108 | 47x |
y = y + r * sin(angles) |
| 109 |
) |
|
| 110 |
} |
|
| 111 | ||
| 112 |
#' Generate Star Vertices |
|
| 113 |
#' |
|
| 114 |
#' @param x Center x coordinate. |
|
| 115 |
#' @param y Center y coordinate. |
|
| 116 |
#' @param r Outer radius. |
|
| 117 |
#' @param n_points Number of star points. |
|
| 118 |
#' @param inner_ratio Ratio of inner to outer radius. |
|
| 119 |
#' @return List with x, y vectors of vertices. |
|
| 120 |
#' @keywords internal |
|
| 121 |
star_vertices <- function(x, y, r, n_points = 5, inner_ratio = 0.4) {
|
|
| 122 | 18x |
n_vertices <- n_points * 2 |
| 123 | 18x |
angles <- seq(pi/2, pi/2 + 2*pi * (1 - 1/n_vertices), length.out = n_vertices) |
| 124 | 18x |
radii <- rep(c(r, r * inner_ratio), n_points) |
| 125 | ||
| 126 | 18x |
list( |
| 127 | 18x |
x = x + radii * cos(angles), |
| 128 | 18x |
y = y + radii * sin(angles) |
| 129 |
) |
|
| 130 |
} |
|
| 131 | ||
| 132 |
#' Generate Heart Vertices |
|
| 133 |
#' |
|
| 134 |
#' @param x Center x coordinate. |
|
| 135 |
#' @param y Center y coordinate. |
|
| 136 |
#' @param r Scale (size). |
|
| 137 |
#' @param n Number of vertices. |
|
| 138 |
#' @return List with x, y vectors of vertices. |
|
| 139 |
#' @keywords internal |
|
| 140 |
heart_vertices <- function(x, y, r, n = 100) {
|
|
| 141 | 14x |
t <- seq(0, 2*pi, length.out = n) |
| 142 | ||
| 143 |
# Heart parametric equations |
|
| 144 | 14x |
hx <- 16 * sin(t)^3 |
| 145 | 14x |
hy <- 13 * cos(t) - 5 * cos(2*t) - 2 * cos(3*t) - cos(4*t) |
| 146 | ||
| 147 |
# Normalize and scale |
|
| 148 | 14x |
max_extent <- max(abs(c(hx, hy))) |
| 149 | 14x |
hx <- hx / max_extent * r * 0.8 |
| 150 | 14x |
hy <- hy / max_extent * r * 0.8 |
| 151 | ||
| 152 | 14x |
list( |
| 153 | 14x |
x = x + hx, |
| 154 | 14x |
y = y + hy |
| 155 |
) |
|
| 156 |
} |
|
| 157 | ||
| 158 |
#' Generate Ellipse Vertices |
|
| 159 |
#' |
|
| 160 |
#' @param x Center x coordinate. |
|
| 161 |
#' @param y Center y coordinate. |
|
| 162 |
#' @param rx Horizontal radius. |
|
| 163 |
#' @param ry Vertical radius. |
|
| 164 |
#' @param n Number of vertices. |
|
| 165 |
#' @return List with x, y vectors of vertices. |
|
| 166 |
#' @keywords internal |
|
| 167 |
ellipse_vertices <- function(x, y, rx, ry, n = 50) {
|
|
| 168 | 14x |
angles <- seq(0, 2 * pi, length.out = n + 1)[-1] |
| 169 | 14x |
list( |
| 170 | 14x |
x = x + rx * cos(angles), |
| 171 | 14x |
y = y + ry * sin(angles) |
| 172 |
) |
|
| 173 |
} |
|
| 174 | ||
| 175 |
#' Generate Cross/Plus Vertices |
|
| 176 |
#' |
|
| 177 |
#' @param x Center x coordinate. |
|
| 178 |
#' @param y Center y coordinate. |
|
| 179 |
#' @param r Half-size. |
|
| 180 |
#' @param thickness Arm thickness as ratio of r. |
|
| 181 |
#' @return List with x, y vectors of vertices. |
|
| 182 |
#' @keywords internal |
|
| 183 |
cross_vertices <- function(x, y, r, thickness = 0.3) {
|
|
| 184 | 13x |
t <- r * thickness |
| 185 | ||
| 186 |
# 12-point cross shape |
|
| 187 | 13x |
list( |
| 188 | 13x |
x = x + c(-t, t, t, r, r, t, t, -t, -t, -r, -r, -t), |
| 189 | 13x |
y = y + c(r, r, t, t, -t, -t, -r, -r, -t, -t, t, t) |
| 190 |
) |
|
| 191 |
} |
|
| 192 | ||
| 193 |
#' Generate Regular Polygon Vertices |
|
| 194 |
#' |
|
| 195 |
#' @param x Center x coordinate. |
|
| 196 |
#' @param y Center y coordinate. |
|
| 197 |
#' @param r Radius. |
|
| 198 |
#' @param n Number of sides. |
|
| 199 |
#' @param rotation Starting angle in radians (default: first vertex at top). |
|
| 200 |
#' @return List with x, y vectors of vertices. |
|
| 201 |
#' @keywords internal |
|
| 202 |
regular_polygon_vertices <- function(x, y, r, n, rotation = pi/2) {
|
|
| 203 | 4x |
angles <- seq(rotation, rotation + 2*pi * (1 - 1/n), length.out = n) |
| 204 | 4x |
list( |
| 205 | 4x |
x = x + r * cos(angles), |
| 206 | 4x |
y = y + r * sin(angles) |
| 207 |
) |
|
| 208 |
} |
|
| 209 | ||
| 210 |
#' Inset Polygon Vertices |
|
| 211 |
#' |
|
| 212 |
#' Creates an inner polygon by scaling vertices toward the centroid. |
|
| 213 |
#' |
|
| 214 |
#' @param outer List with x, y vectors of outer polygon vertices. |
|
| 215 |
#' @param inner_ratio Ratio to scale vertices toward center (0-1). |
|
| 216 |
#' @return List with x, y vectors of inner polygon vertices. |
|
| 217 |
#' @keywords internal |
|
| 218 |
inset_polygon_vertices <- function(outer, inner_ratio) {
|
|
| 219 |
# Calculate centroid |
|
| 220 | 91x |
cx <- mean(outer$x) |
| 221 | 91x |
cy <- mean(outer$y) |
| 222 | ||
| 223 |
# Scale vertices toward centroid |
|
| 224 | 91x |
list( |
| 225 | 91x |
x = cx + (outer$x - cx) * inner_ratio, |
| 226 | 91x |
y = cy + (outer$y - cy) * inner_ratio |
| 227 |
) |
|
| 228 |
} |
|
| 229 | ||
| 230 |
#' Get Polygon Vertices by Shape Name |
|
| 231 |
#' |
|
| 232 |
#' Returns outer polygon vertices for donut ring shapes. |
|
| 233 |
#' |
|
| 234 |
#' @param shape Shape name. |
|
| 235 |
#' @param x Center x coordinate. |
|
| 236 |
#' @param y Center y coordinate. |
|
| 237 |
#' @param r Radius/size. |
|
| 238 |
#' @return List with x, y vectors of vertices. |
|
| 239 |
#' @keywords internal |
|
| 240 |
get_donut_base_vertices <- function(shape, x, y, r) {
|
|
| 241 | 92x |
switch(shape, |
| 242 | 2x |
circle = circle_vertices(x, y, r, n = 100), |
| 243 | 33x |
square = square_vertices(x, y, r), |
| 244 | 3x |
rectangle = rectangle_vertices(x, y, r, r * 0.7), |
| 245 | 11x |
triangle = triangle_vertices(x, y, r), |
| 246 | 6x |
diamond = diamond_vertices(x, y, r), |
| 247 | 5x |
pentagon = pentagon_vertices(x, y, r), |
| 248 | 31x |
hexagon = hexagon_vertices(x, y, r), |
| 249 |
# Default to circle |
|
| 250 | 1x |
circle_vertices(x, y, r, n = 100) |
| 251 |
) |
|
| 252 |
} |
|
| 253 | ||
| 254 |
#' Generate Gear Vertices |
|
| 255 |
#' |
|
| 256 |
#' @param x Center x coordinate. |
|
| 257 |
#' @param y Center y coordinate. |
|
| 258 |
#' @param r Outer radius. |
|
| 259 |
#' @param n_teeth Number of teeth. |
|
| 260 |
#' @return List with x, y vectors of vertices. |
|
| 261 |
#' @keywords internal |
|
| 262 |
gear_vertices <- function(x, y, r, n_teeth = 8) {
|
|
| 263 | 6x |
inner_r <- r * 0.65 |
| 264 | 6x |
tooth_height <- r * 0.25 |
| 265 | ||
| 266 | 6x |
n_pts_per_tooth <- 8 |
| 267 | 6x |
n_total <- n_teeth * n_pts_per_tooth |
| 268 | 6x |
angles <- seq(0, 2 * pi, length.out = n_total + 1)[-1] |
| 269 | ||
| 270 | 6x |
gear_x <- numeric(n_total) |
| 271 | 6x |
gear_y <- numeric(n_total) |
| 272 | ||
| 273 | 6x |
for (i in seq_len(n_total)) {
|
| 274 | 384x |
pos_in_tooth <- (i - 1) %% n_pts_per_tooth |
| 275 | ||
| 276 | 384x |
if (pos_in_tooth < 2 || pos_in_tooth >= 6) {
|
| 277 | 192x |
rad <- inner_r |
| 278 |
} else {
|
|
| 279 | 192x |
rad <- inner_r + tooth_height |
| 280 |
} |
|
| 281 | ||
| 282 | 384x |
gear_x[i] <- x + rad * cos(angles[i]) |
| 283 | 384x |
gear_y[i] <- y + rad * sin(angles[i]) |
| 284 |
} |
|
| 285 | ||
| 286 | 6x |
list(x = gear_x, y = gear_y) |
| 287 |
} |
|
| 288 | ||
| 289 |
#' Generate Cloud Vertices |
|
| 290 |
#' |
|
| 291 |
#' @param x Center x coordinate. |
|
| 292 |
#' @param y Center y coordinate. |
|
| 293 |
#' @param r Radius. |
|
| 294 |
#' @param n Number of vertices. |
|
| 295 |
#' @return List with x, y vectors of vertices. |
|
| 296 |
#' @keywords internal |
|
| 297 |
cloud_vertices <- function(x, y, r, n = 100) {
|
|
| 298 | 5x |
t <- seq(0, 2 * pi, length.out = n) |
| 299 | 5x |
rad <- r * (0.65 + 0.2 * sin(4 * t) + 0.1 * sin(6 * t)) |
| 300 | ||
| 301 | 5x |
list( |
| 302 | 5x |
x = x + rad * cos(t), |
| 303 | 5x |
y = y + rad * sin(t) * 0.6 + r * 0.1 |
| 304 |
) |
|
| 305 |
} |
|
| 306 | ||
| 307 |
#' Generate Brain Vertices |
|
| 308 |
#' |
|
| 309 |
#' @param x Center x coordinate. |
|
| 310 |
#' @param y Center y coordinate. |
|
| 311 |
#' @param r Radius. |
|
| 312 |
#' @param n Number of vertices. |
|
| 313 |
#' @return List with x, y vectors of vertices. |
|
| 314 |
#' @keywords internal |
|
| 315 |
brain_vertices <- function(x, y, r, n = 80) {
|
|
| 316 | 5x |
t <- seq(0, 2 * pi, length.out = n) |
| 317 | 5x |
rad <- r * (0.7 + 0.15 * sin(3 * t) + 0.1 * sin(5 * t) + 0.05 * cos(7 * t)) |
| 318 | ||
| 319 | 5x |
list( |
| 320 | 5x |
x = x + rad * cos(t), |
| 321 | 5x |
y = y + rad * sin(t) * 0.85 |
| 322 |
) |
|
| 323 |
} |
|
| 324 | ||
| 325 |
#' Get Shape Vertices |
|
| 326 |
#' |
|
| 327 |
#' Dispatch function to get vertices for any supported shape. |
|
| 328 |
#' |
|
| 329 |
#' @param shape Shape name. |
|
| 330 |
#' @param x Center x coordinate. |
|
| 331 |
#' @param y Center y coordinate. |
|
| 332 |
#' @param r Radius/size. |
|
| 333 |
#' @param r2 Secondary radius (for ellipse, rectangle). |
|
| 334 |
#' @param ... Additional shape-specific parameters. |
|
| 335 |
#' @return List with x, y vectors of vertices. |
|
| 336 |
#' @keywords internal |
|
| 337 |
get_shape_vertices <- function(shape, x, y, r, r2 = NULL, ...) {
|
|
| 338 | 6x |
if (is.null(r2)) r2 <- r |
| 339 | ||
| 340 | 207x |
switch(shape, |
| 341 | 1x |
circle = circle_vertices(x, y, r), |
| 342 | 1x |
square = square_vertices(x, y, r), |
| 343 | 7x |
rectangle = rectangle_vertices(x, y, r, r2), |
| 344 | 30x |
triangle = triangle_vertices(x, y, r), |
| 345 | 78x |
diamond = diamond_vertices(x, y, r), |
| 346 | 14x |
pentagon = pentagon_vertices(x, y, r), |
| 347 | 14x |
hexagon = hexagon_vertices(x, y, r), |
| 348 | 14x |
star = star_vertices(x, y, r, ...), |
| 349 | 12x |
heart = heart_vertices(x, y, r), |
| 350 | 12x |
ellipse = ellipse_vertices(x, y, r, r2), |
| 351 | 10x |
cross = cross_vertices(x, y, r, ...), |
| 352 | 3x |
gear = gear_vertices(x, y, r, ...), |
| 353 | 3x |
cloud = cloud_vertices(x, y, r), |
| 354 | 3x |
brain = brain_vertices(x, y, r), |
| 355 |
# Default to circle |
|
| 356 | 5x |
circle_vertices(x, y, r) |
| 357 |
) |
|
| 358 |
} |
| 1 |
#' @title Edge Aesthetics |
|
| 2 |
#' @description Functions for setting edge aesthetic properties. |
|
| 3 |
#' @name aes-edges |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Set Edge Aesthetics |
|
| 7 |
#' |
|
| 8 |
#' Customize the visual appearance of edges in a network plot. |
|
| 9 |
#' |
|
| 10 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 11 |
#' Matrices and other inputs are auto-converted. |
|
| 12 |
#' @param width Edge width. Can be a single value, vector (per-edge), or "weight". |
|
| 13 |
#' @param edge_size Base edge size for weight scaling. NULL (default) uses adaptive sizing |
|
| 14 |
#' based on network size: `15 * exp(-n_nodes/90) + 1`. Larger values = thicker edges. |
|
| 15 |
#' @param esize Deprecated. Use `edge_size` instead. |
|
| 16 |
#' @param edge_width_range Output width range as c(min, max) for weight-based scaling. |
|
| 17 |
#' Default c(0.5, 4). Edges are scaled to fit within this range. |
|
| 18 |
#' @param edge_scale_mode Scaling mode for edge weights: "linear" (default), |
|
| 19 |
#' "log" (for wide weight ranges), "sqrt" (moderate compression), |
|
| 20 |
#' or "rank" (equal visual spacing). |
|
| 21 |
#' @param edge_cutoff Two-tier cutoff for edge width scaling. NULL (default) = auto 75th percentile. |
|
| 22 |
#' 0 = disabled. Positive number = manual threshold. |
|
| 23 |
#' @param cut Deprecated. Use `edge_cutoff` instead. |
|
| 24 |
#' @param color Edge color. Can be a single color, vector, or "weight" for |
|
| 25 |
#' automatic coloring based on edge weights. |
|
| 26 |
#' @param edge_positive_color Color for positive edge weights. |
|
| 27 |
#' @param positive_color Deprecated. Use `edge_positive_color` instead. |
|
| 28 |
#' @param edge_negative_color Color for negative edge weights. |
|
| 29 |
#' @param negative_color Deprecated. Use `edge_negative_color` instead. |
|
| 30 |
#' @param alpha Edge transparency (0-1). |
|
| 31 |
#' @param style Line style: "solid", "dashed", "dotted", "longdash", "twodash". |
|
| 32 |
#' @param curvature Edge curvature amount (0 = straight). |
|
| 33 |
#' @param arrow_size Size of arrow heads for directed networks. |
|
| 34 |
#' @param show_arrows Logical. Show arrows? Default TRUE for directed networks. |
|
| 35 |
#' @param maximum Maximum edge weight for scaling width. Weights above this are |
|
| 36 |
#' capped. Similar to qgraph's maximum parameter. |
|
| 37 |
#' @param width_scale Scale factor for edge widths. Values > 1 make edges thicker, |
|
| 38 |
#' values < 1 make them thinner. Applied after all other width calculations. |
|
| 39 |
#' @param labels Edge labels. Can be TRUE (show weights), a vector, or column name. |
|
| 40 |
#' @param label_size Edge label text size. |
|
| 41 |
#' @param label_color Edge label text color. |
|
| 42 |
#' @param label_position Position along edge (0 = source, 0.5 = middle, 1 = target). |
|
| 43 |
#' @param label_offset Perpendicular offset from edge line. |
|
| 44 |
#' @param label_bg Background color for edge labels (default "white"). Set to NA for transparent. |
|
| 45 |
#' @param label_bg_padding Padding around label text as proportion of text size (default 0.3). |
|
| 46 |
#' @param label_fontface Font face: "plain", "bold", "italic", "bold.italic" (default "plain"). |
|
| 47 |
#' @param label_border Border style: NULL (none), "rect", "rounded", "circle" (default NULL). |
|
| 48 |
#' @param label_border_color Border color for label border (default "gray50"). |
|
| 49 |
#' @param label_underline Logical. Underline the label text? (default FALSE). |
|
| 50 |
#' @param label_shadow Logical. Enable drop shadow for labels? (default FALSE). |
|
| 51 |
#' @param label_shadow_color Color for label shadow (default "gray40"). |
|
| 52 |
#' @param label_shadow_offset Offset distance for shadow in points (default 0.5). |
|
| 53 |
#' @param label_shadow_alpha Transparency for shadow (0-1, default 0.5). |
|
| 54 |
#' @param bidirectional Logical. Show arrows at both ends of edges? |
|
| 55 |
#' @param loop_rotation Angle in radians for self-loop direction (default: pi/2 = top). |
|
| 56 |
#' @param curve_shape Spline tension for curved edges (-1 to 1, default: 0). |
|
| 57 |
#' @param curve_pivot Pivot position along edge for curve control point (0-1, default: 0.5). |
|
| 58 |
#' @param curves Curve mode: FALSE (straight edges), "mutual" (only curve reciprocal pairs), |
|
| 59 |
#' or "force" (curve all edges). Default FALSE. |
|
| 60 |
#' @param ci Numeric vector of CI widths (0-1 scale). Larger values = more uncertainty. |
|
| 61 |
#' @param ci_scale Width multiplier for CI underlay thickness. Default 2. |
|
| 62 |
#' @param ci_alpha Transparency for CI underlay (0-1). Default 0.15. |
|
| 63 |
#' @param ci_color CI underlay color. NA (default) uses main edge color. |
|
| 64 |
#' @param ci_style Line type for CI underlay: 1=solid, 2=dashed, 3=dotted. Default 2. |
|
| 65 |
#' @param ci_arrows Logical: show arrows on CI underlay? Default FALSE. |
|
| 66 |
#' @param ci_lower Numeric vector of lower CI bounds for labels. |
|
| 67 |
#' @param ci_upper Numeric vector of upper CI bounds for labels. |
|
| 68 |
#' @param label_style Preset style: "none", "estimate", "full", "range", "stars". |
|
| 69 |
#' @param label_template Template with placeholders: \{est\}, \{range\}, \{low\}, \{up\}, \{p\}, \{stars\}.
|
|
| 70 |
#' @param label_digits Decimal places for estimates in template. Default 2. |
|
| 71 |
#' @param label_ci_format CI format: "bracket" for `[low, up]` or "dash" for `low-up`. |
|
| 72 |
#' @param label_p Numeric vector of p-values for edges. |
|
| 73 |
#' @param label_p_digits Decimal places for p-values. Default 3. |
|
| 74 |
#' @param label_p_prefix Prefix for p-values. Default "p=". |
|
| 75 |
#' @param label_stars Stars for labels: character vector, TRUE (compute from p), |
|
| 76 |
#' or numeric (treated as p-values). |
|
| 77 |
#' |
|
| 78 |
#' @details |
|
| 79 |
#' ## Vectorization |
|
| 80 |
#' Most aesthetic parameters can be specified as: |
|
| 81 |
#' \itemize{
|
|
| 82 |
#' \item \strong{Single value}: Applied to all edges
|
|
| 83 |
#' \item \strong{Vector}: Per-edge values (must match edge count)
|
|
| 84 |
#' \item \strong{"weight"}: Special value for \code{width} and \code{color} that
|
|
| 85 |
#' auto-maps from edge weights |
|
| 86 |
#' } |
|
| 87 |
#' |
|
| 88 |
#' ## Weight-Based Styling |
|
| 89 |
#' When \code{color = "weight"}, edges are colored by sign:
|
|
| 90 |
#' \itemize{
|
|
| 91 |
#' \item Positive weights use \code{edge_positive_color} (default: green)
|
|
| 92 |
#' \item Negative weights use \code{edge_negative_color} (default: red)
|
|
| 93 |
#' } |
|
| 94 |
#' |
|
| 95 |
#' When \code{width = "weight"}, edge widths scale with absolute weight values,
|
|
| 96 |
#' respecting the \code{maximum} parameter if set.
|
|
| 97 |
#' |
|
| 98 |
#' ## Edge Label Templates |
|
| 99 |
#' For statistical output (e.g., regression coefficients with CIs), use templates: |
|
| 100 |
#' \itemize{
|
|
| 101 |
#' \item \code{label_template = "\{est\}"}: Show estimate only
|
|
| 102 |
#' \item \code{label_template = "\{est\} [\{low\}, \{up\}]"}: Estimate with CI
|
|
| 103 |
#' \item \code{label_template = "\{est\}\{stars\}"}: Estimate with significance
|
|
| 104 |
#' } |
|
| 105 |
#' |
|
| 106 |
#' Preset styles via \code{label_style}:
|
|
| 107 |
#' \itemize{
|
|
| 108 |
#' \item \code{"estimate"}: Weight/estimate only
|
|
| 109 |
#' \item \code{"full"}: Estimate + CI in brackets
|
|
| 110 |
#' \item \code{"range"}: CI range only
|
|
| 111 |
#' \item \code{"stars"}: Significance stars
|
|
| 112 |
#' } |
|
| 113 |
#' |
|
| 114 |
#' ## CI Underlays |
|
| 115 |
#' Visualize uncertainty by drawing a wider, semi-transparent edge behind: |
|
| 116 |
#' \itemize{
|
|
| 117 |
#' \item \code{ci}: Vector of CI widths (0-1 scale)
|
|
| 118 |
#' \item \code{ci_scale}: Width multiplier (default 2)
|
|
| 119 |
#' \item \code{ci_alpha}: Transparency (default 0.15)
|
|
| 120 |
#' } |
|
| 121 |
#' |
|
| 122 |
#' @return Modified cograph_network object that can be piped to further customization |
|
| 123 |
#' functions or plotting functions. |
|
| 124 |
#' |
|
| 125 |
#' @seealso |
|
| 126 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 127 |
#' \code{\link{cograph}} for network creation,
|
|
| 128 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting,
|
|
| 129 |
#' \code{\link{sn_layout}} for layout algorithms,
|
|
| 130 |
#' \code{\link{sn_theme}} for visual themes
|
|
| 131 |
#' |
|
| 132 |
#' @export |
|
| 133 |
#' |
|
| 134 |
#' @examples |
|
| 135 |
#' adj <- matrix(c(0, 1, -0.5, 1, 0, 1, -0.5, 1, 0), nrow = 3) |
|
| 136 |
#' |
|
| 137 |
#' # Basic: auto-style by weight |
|
| 138 |
#' cograph(adj) |> |
|
| 139 |
#' sn_edges(width = "weight", color = "weight") |
|
| 140 |
#' |
|
| 141 |
#' # Direct matrix input (auto-converted) |
|
| 142 |
#' adj |> sn_edges(width = 2, color = "gray50") |
|
| 143 |
#' |
|
| 144 |
#' # Custom positive/negative colors |
|
| 145 |
#' cograph(adj) |> |
|
| 146 |
#' sn_edges( |
|
| 147 |
#' color = "weight", |
|
| 148 |
#' edge_positive_color = "darkblue", |
|
| 149 |
#' edge_negative_color = "darkred" |
|
| 150 |
#' ) |> |
|
| 151 |
#' splot() |
|
| 152 |
#' |
|
| 153 |
#' # Edge labels showing weights |
|
| 154 |
#' cograph(adj) |> |
|
| 155 |
#' sn_edges(labels = TRUE, label_size = 0.8) |> |
|
| 156 |
#' splot() |
|
| 157 |
#' |
|
| 158 |
#' # Statistical output with CI template |
|
| 159 |
#' # Suppose we have estimates, lower/upper CI bounds |
|
| 160 |
#' estimates <- c(0.5, -0.3, 0.8) |
|
| 161 |
#' ci_lo <- c(0.2, -0.6, 0.5) |
|
| 162 |
#' ci_hi <- c(0.8, -0.1, 1.1) |
|
| 163 |
#' |
|
| 164 |
#' \dontrun{
|
|
| 165 |
#' cograph(adj) |> |
|
| 166 |
#' sn_edges( |
|
| 167 |
#' label_template = "{est} [{low}, {up}]",
|
|
| 168 |
#' ci_lower = ci_lo, |
|
| 169 |
#' ci_upper = ci_hi, |
|
| 170 |
#' label_digits = 2 |
|
| 171 |
#' ) |> |
|
| 172 |
#' splot() |
|
| 173 |
#' } |
|
| 174 |
#' |
|
| 175 |
#' # Curved edges for reciprocal pairs |
|
| 176 |
#' cograph(adj) |> |
|
| 177 |
#' sn_edges(curves = "mutual", curvature = 0.3) |> |
|
| 178 |
#' splot() |
|
| 179 |
sn_edges <- function(network, |
|
| 180 |
width = NULL, |
|
| 181 |
edge_size = NULL, |
|
| 182 |
esize = NULL, # Deprecated: use edge_size |
|
| 183 |
edge_width_range = NULL, |
|
| 184 |
edge_scale_mode = NULL, |
|
| 185 |
edge_cutoff = NULL, |
|
| 186 |
cut = NULL, # Deprecated: use edge_cutoff |
|
| 187 |
color = NULL, |
|
| 188 |
edge_positive_color = NULL, |
|
| 189 |
positive_color = NULL, # Deprecated: use edge_positive_color |
|
| 190 |
edge_negative_color = NULL, |
|
| 191 |
negative_color = NULL, # Deprecated: use edge_negative_color |
|
| 192 |
alpha = NULL, |
|
| 193 |
style = NULL, |
|
| 194 |
curvature = NULL, |
|
| 195 |
arrow_size = NULL, |
|
| 196 |
show_arrows = NULL, |
|
| 197 |
maximum = NULL, |
|
| 198 |
width_scale = NULL, |
|
| 199 |
labels = NULL, |
|
| 200 |
label_size = NULL, |
|
| 201 |
label_color = NULL, |
|
| 202 |
label_position = NULL, |
|
| 203 |
label_offset = NULL, |
|
| 204 |
label_bg = NULL, |
|
| 205 |
label_bg_padding = NULL, |
|
| 206 |
label_fontface = NULL, |
|
| 207 |
label_border = NULL, |
|
| 208 |
label_border_color = NULL, |
|
| 209 |
label_underline = NULL, |
|
| 210 |
label_shadow = NULL, |
|
| 211 |
label_shadow_color = NULL, |
|
| 212 |
label_shadow_offset = NULL, |
|
| 213 |
label_shadow_alpha = NULL, |
|
| 214 |
bidirectional = NULL, |
|
| 215 |
loop_rotation = NULL, |
|
| 216 |
curve_shape = NULL, |
|
| 217 |
curve_pivot = NULL, |
|
| 218 |
curves = NULL, |
|
| 219 |
# CI underlay parameters |
|
| 220 |
ci = NULL, |
|
| 221 |
ci_scale = NULL, |
|
| 222 |
ci_alpha = NULL, |
|
| 223 |
ci_color = NULL, |
|
| 224 |
ci_style = NULL, |
|
| 225 |
ci_arrows = NULL, |
|
| 226 |
# Label template parameters |
|
| 227 |
ci_lower = NULL, |
|
| 228 |
ci_upper = NULL, |
|
| 229 |
label_style = NULL, |
|
| 230 |
label_template = NULL, |
|
| 231 |
label_digits = NULL, |
|
| 232 |
label_ci_format = NULL, |
|
| 233 |
label_p = NULL, |
|
| 234 |
label_p_digits = NULL, |
|
| 235 |
label_p_prefix = NULL, |
|
| 236 |
label_stars = NULL) {
|
|
| 237 | ||
| 238 |
# Handle deprecated parameters |
|
| 239 | 672x |
edge_size <- handle_deprecated_param(edge_size, esize, "edge_size", "esize") |
| 240 | 672x |
edge_cutoff <- handle_deprecated_param(edge_cutoff, cut, "edge_cutoff", "cut") |
| 241 | 672x |
edge_positive_color <- handle_deprecated_param(edge_positive_color, positive_color, |
| 242 | 672x |
"edge_positive_color", "positive_color") |
| 243 | 672x |
edge_negative_color <- handle_deprecated_param(edge_negative_color, negative_color, |
| 244 | 672x |
"edge_negative_color", "negative_color") |
| 245 | ||
| 246 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 247 | 672x |
network <- ensure_cograph_network(network) |
| 248 | ||
| 249 |
# Clone the network to maintain immutability |
|
| 250 | 672x |
new_net <- network$network$clone_network() |
| 251 | ||
| 252 |
# Get edge count for validation |
|
| 253 | 672x |
edges_df <- new_net$get_edges() |
| 254 | 672x |
m <- if (is.null(edges_df)) 0 else nrow(edges_df) |
| 255 | ||
| 256 |
# Build aesthetics list |
|
| 257 | 672x |
aes <- list() |
| 258 | ||
| 259 | 672x |
if (!is.null(width)) {
|
| 260 | 19x |
if (identical(width, "weight") && !is.null(edges_df$weight)) {
|
| 261 |
# Scale width by weight, respecting maximum if set |
|
| 262 | 4x |
weights_for_scale <- abs(edges_df$weight) |
| 263 | 4x |
if (!is.null(maximum)) {
|
| 264 | 1x |
weights_for_scale <- pmin(weights_for_scale, maximum) |
| 265 |
} |
|
| 266 | 4x |
aes$width <- scale_edge_widths_simple(weights_for_scale, maximum = maximum) |
| 267 |
} else {
|
|
| 268 | 15x |
aes$width <- resolve_aesthetic(width, edges_df, m) |
| 269 |
} |
|
| 270 |
} |
|
| 271 | ||
| 272 | 672x |
if (!is.null(maximum)) {
|
| 273 | 5x |
aes$maximum <- maximum |
| 274 |
} |
|
| 275 | ||
| 276 |
# Edge width scaling parameters |
|
| 277 | 672x |
if (!is.null(edge_size)) {
|
| 278 | 8x |
aes$esize <- edge_size |
| 279 |
} |
|
| 280 | ||
| 281 | 672x |
if (!is.null(edge_width_range)) {
|
| 282 | 5x |
aes$edge_width_range <- edge_width_range |
| 283 |
} |
|
| 284 | ||
| 285 | 672x |
if (!is.null(edge_scale_mode)) {
|
| 286 | 514x |
valid_modes <- c("linear", "log", "sqrt", "rank")
|
| 287 | 514x |
if (!edge_scale_mode %in% valid_modes) {
|
| 288 | 2x |
stop("edge_scale_mode must be one of: ", paste(valid_modes, collapse = ", "),
|
| 289 | 2x |
call. = FALSE) |
| 290 |
} |
|
| 291 | 512x |
aes$edge_scale_mode <- edge_scale_mode |
| 292 |
} |
|
| 293 | ||
| 294 | 670x |
if (!is.null(edge_cutoff)) {
|
| 295 | 6x |
aes$cut <- edge_cutoff |
| 296 |
} |
|
| 297 | ||
| 298 | 670x |
if (!is.null(width_scale)) {
|
| 299 | 2x |
aes$width_scale <- width_scale |
| 300 |
} |
|
| 301 | ||
| 302 | 670x |
if (!is.null(color)) {
|
| 303 | 25x |
if (identical(color, "weight") && !is.null(edges_df$weight)) {
|
| 304 |
# Color by weight sign: positive = green, negative = red |
|
| 305 | 3x |
current_aes <- new_net$get_edge_aes() |
| 306 | 3x |
pos_col <- if (!is.null(edge_positive_color)) edge_positive_color else current_aes$positive_color |
| 307 | 3x |
neg_col <- if (!is.null(edge_negative_color)) edge_negative_color else current_aes$negative_color |
| 308 | 3x |
aes$color <- ifelse(edges_df$weight >= 0, pos_col, neg_col) |
| 309 |
} else {
|
|
| 310 | 22x |
aes$color <- resolve_aesthetic(color, edges_df, m) |
| 311 |
} |
|
| 312 |
} |
|
| 313 | ||
| 314 | 670x |
if (!is.null(edge_positive_color)) {
|
| 315 | 11x |
aes$positive_color <- edge_positive_color |
| 316 |
} |
|
| 317 | ||
| 318 | 670x |
if (!is.null(edge_negative_color)) {
|
| 319 | 10x |
aes$negative_color <- edge_negative_color |
| 320 |
} |
|
| 321 | ||
| 322 | 670x |
if (!is.null(alpha)) {
|
| 323 | 18x |
validate_range(alpha, 0, 1, "alpha") |
| 324 | 14x |
aes$alpha <- resolve_aesthetic(alpha, edges_df, m) |
| 325 |
} |
|
| 326 | ||
| 327 | 666x |
if (!is.null(style)) {
|
| 328 | 30x |
valid_styles <- c("solid", "dashed", "dotted", "longdash", "twodash")
|
| 329 | 30x |
style_vals <- resolve_aesthetic(style, edges_df, m) |
| 330 | 30x |
if (!all(style_vals %in% valid_styles)) {
|
| 331 | 2x |
stop("style must be one of: ", paste(valid_styles, collapse = ", "),
|
| 332 | 2x |
call. = FALSE) |
| 333 |
} |
|
| 334 | 28x |
aes$style <- style_vals |
| 335 |
} |
|
| 336 | ||
| 337 | 664x |
if (!is.null(curvature)) {
|
| 338 | 17x |
aes$curvature <- resolve_aesthetic(curvature, edges_df, m) |
| 339 |
} |
|
| 340 | ||
| 341 | 664x |
if (!is.null(arrow_size)) {
|
| 342 | 12x |
aes$arrow_size <- arrow_size |
| 343 |
} |
|
| 344 | ||
| 345 | 664x |
if (!is.null(show_arrows)) {
|
| 346 | 29x |
aes$show_arrows <- show_arrows |
| 347 |
} |
|
| 348 | ||
| 349 | 664x |
if (!is.null(labels)) {
|
| 350 | 39x |
if (isTRUE(labels) && !is.null(edges_df$weight)) {
|
| 351 |
# Auto-show weights as labels |
|
| 352 | 38x |
aes$labels <- round(edges_df$weight, 2) |
| 353 | 1x |
} else if (!isTRUE(labels) && !isFALSE(labels)) {
|
| 354 | 1x |
aes$labels <- resolve_aesthetic(labels, edges_df, m) |
| 355 |
} |
|
| 356 |
} |
|
| 357 | ||
| 358 | 664x |
if (!is.null(label_size)) {
|
| 359 | 9x |
aes$label_size <- label_size |
| 360 |
} |
|
| 361 | ||
| 362 | 664x |
if (!is.null(label_color)) {
|
| 363 | 4x |
aes$label_color <- label_color |
| 364 |
} |
|
| 365 | ||
| 366 | 664x |
if (!is.null(label_position)) {
|
| 367 | 8x |
aes$label_position <- label_position |
| 368 |
} |
|
| 369 | ||
| 370 | 664x |
if (!is.null(label_offset)) {
|
| 371 | 3x |
aes$label_offset <- label_offset |
| 372 |
} |
|
| 373 | ||
| 374 | 664x |
if (!is.null(label_bg)) {
|
| 375 | 6x |
aes$label_bg <- label_bg |
| 376 |
} |
|
| 377 | ||
| 378 | 664x |
if (!is.null(label_bg_padding)) {
|
| 379 | 1x |
aes$label_bg_padding <- label_bg_padding |
| 380 |
} |
|
| 381 | ||
| 382 | 664x |
if (!is.null(label_fontface)) {
|
| 383 | 11x |
valid_faces <- c("plain", "bold", "italic", "bold.italic")
|
| 384 | 11x |
if (!label_fontface %in% valid_faces) {
|
| 385 | 2x |
stop("label_fontface must be one of: ", paste(valid_faces, collapse = ", "),
|
| 386 | 2x |
call. = FALSE) |
| 387 |
} |
|
| 388 | 9x |
aes$label_fontface <- label_fontface |
| 389 |
} |
|
| 390 | ||
| 391 | 662x |
if (!is.null(label_border)) {
|
| 392 | 13x |
valid_borders <- c("rect", "rounded", "circle")
|
| 393 | 13x |
if (!label_border %in% valid_borders) {
|
| 394 | 2x |
stop("label_border must be one of: ", paste(valid_borders, collapse = ", "),
|
| 395 | 2x |
call. = FALSE) |
| 396 |
} |
|
| 397 | 11x |
aes$label_border <- label_border |
| 398 |
} |
|
| 399 | ||
| 400 | 660x |
if (!is.null(label_border_color)) {
|
| 401 | 4x |
aes$label_border_color <- label_border_color |
| 402 |
} |
|
| 403 | ||
| 404 | 660x |
if (!is.null(label_underline)) {
|
| 405 | 3x |
aes$label_underline <- label_underline |
| 406 |
} |
|
| 407 | ||
| 408 | 660x |
if (!is.null(label_shadow)) {
|
| 409 | 4x |
aes$label_shadow <- label_shadow |
| 410 |
} |
|
| 411 | ||
| 412 | 660x |
if (!is.null(label_shadow_color)) {
|
| 413 | 4x |
aes$label_shadow_color <- label_shadow_color |
| 414 |
} |
|
| 415 | ||
| 416 | 660x |
if (!is.null(label_shadow_offset)) {
|
| 417 | 4x |
aes$label_shadow_offset <- label_shadow_offset |
| 418 |
} |
|
| 419 | ||
| 420 | 660x |
if (!is.null(label_shadow_alpha)) {
|
| 421 | 7x |
validate_range(label_shadow_alpha, 0, 1, "label_shadow_alpha") |
| 422 | 4x |
aes$label_shadow_alpha <- label_shadow_alpha |
| 423 |
} |
|
| 424 | ||
| 425 | 657x |
if (!is.null(bidirectional)) {
|
| 426 | 6x |
aes$bidirectional <- resolve_aesthetic(bidirectional, edges_df, m) |
| 427 |
} |
|
| 428 | ||
| 429 | 657x |
if (!is.null(loop_rotation)) {
|
| 430 | 9x |
aes$loop_rotation <- resolve_aesthetic(loop_rotation, edges_df, m) |
| 431 |
} |
|
| 432 | ||
| 433 | 657x |
if (!is.null(curve_shape)) {
|
| 434 | 3x |
aes$curve_shape <- resolve_aesthetic(curve_shape, edges_df, m) |
| 435 |
} |
|
| 436 | ||
| 437 | 657x |
if (!is.null(curve_pivot)) {
|
| 438 | 3x |
aes$curve_pivot <- resolve_aesthetic(curve_pivot, edges_df, m) |
| 439 |
} |
|
| 440 | ||
| 441 | 657x |
if (!is.null(curves)) {
|
| 442 | 24x |
if (!isFALSE(curves) && !curves %in% c("mutual", "force")) {
|
| 443 | 3x |
stop("curves must be FALSE, 'mutual', or 'force'", call. = FALSE)
|
| 444 |
} |
|
| 445 | 21x |
aes$curves <- curves |
| 446 |
} |
|
| 447 | ||
| 448 |
# CI underlay parameters |
|
| 449 | 654x |
if (!is.null(ci)) {
|
| 450 | 13x |
aes$ci <- resolve_aesthetic(ci, edges_df, m) |
| 451 |
} |
|
| 452 | ||
| 453 | 654x |
if (!is.null(ci_scale)) {
|
| 454 | 3x |
aes$ci_scale <- ci_scale |
| 455 |
} |
|
| 456 | ||
| 457 | 654x |
if (!is.null(ci_alpha)) {
|
| 458 | 6x |
validate_range(ci_alpha, 0, 1, "ci_alpha") |
| 459 | 3x |
aes$ci_alpha <- ci_alpha |
| 460 |
} |
|
| 461 | ||
| 462 | 651x |
if (!is.null(ci_color)) {
|
| 463 | 4x |
aes$ci_color <- ci_color |
| 464 |
} |
|
| 465 | ||
| 466 | 651x |
if (!is.null(ci_style)) {
|
| 467 | 2x |
aes$ci_style <- ci_style |
| 468 |
} |
|
| 469 | ||
| 470 | 651x |
if (!is.null(ci_arrows)) {
|
| 471 | 2x |
aes$ci_arrows <- ci_arrows |
| 472 |
} |
|
| 473 | ||
| 474 |
# Label template parameters |
|
| 475 | 651x |
if (!is.null(ci_lower)) {
|
| 476 | 2x |
aes$ci_lower <- resolve_aesthetic(ci_lower, edges_df, m) |
| 477 |
} |
|
| 478 | ||
| 479 | 651x |
if (!is.null(ci_upper)) {
|
| 480 | 2x |
aes$ci_upper <- resolve_aesthetic(ci_upper, edges_df, m) |
| 481 |
} |
|
| 482 | ||
| 483 | 651x |
if (!is.null(label_style)) {
|
| 484 | 15x |
valid_styles <- c("none", "estimate", "full", "range", "stars")
|
| 485 | 15x |
if (!label_style %in% valid_styles) {
|
| 486 | 2x |
stop("label_style must be one of: ", paste(valid_styles, collapse = ", "),
|
| 487 | 2x |
call. = FALSE) |
| 488 |
} |
|
| 489 | 13x |
aes$label_style <- label_style |
| 490 |
} |
|
| 491 | ||
| 492 | 649x |
if (!is.null(label_template)) {
|
| 493 | 3x |
aes$label_template <- label_template |
| 494 |
} |
|
| 495 | ||
| 496 | 649x |
if (!is.null(label_digits)) {
|
| 497 | 2x |
aes$label_digits <- label_digits |
| 498 |
} |
|
| 499 | ||
| 500 | 649x |
if (!is.null(label_ci_format)) {
|
| 501 | 7x |
valid_formats <- c("bracket", "dash")
|
| 502 | 7x |
if (!label_ci_format %in% valid_formats) {
|
| 503 | 2x |
stop("label_ci_format must be one of: ", paste(valid_formats, collapse = ", "),
|
| 504 | 2x |
call. = FALSE) |
| 505 |
} |
|
| 506 | 5x |
aes$label_ci_format <- label_ci_format |
| 507 |
} |
|
| 508 | ||
| 509 | 647x |
if (!is.null(label_p)) {
|
| 510 | 3x |
aes$label_p <- resolve_aesthetic(label_p, edges_df, m) |
| 511 |
} |
|
| 512 | ||
| 513 | 647x |
if (!is.null(label_p_digits)) {
|
| 514 | 1x |
aes$label_p_digits <- label_p_digits |
| 515 |
} |
|
| 516 | ||
| 517 | 647x |
if (!is.null(label_p_prefix)) {
|
| 518 | 1x |
aes$label_p_prefix <- label_p_prefix |
| 519 |
} |
|
| 520 | ||
| 521 | 647x |
if (!is.null(label_stars)) {
|
| 522 | 1x |
aes$label_stars <- label_stars |
| 523 |
} |
|
| 524 | ||
| 525 |
# Apply aesthetics |
|
| 526 | 647x |
new_net$set_edge_aes(aes) |
| 527 | ||
| 528 |
# Return wrapped object |
|
| 529 | 647x |
as_cograph_network(new_net) |
| 530 |
} |
|
| 531 | ||
| 532 |
#' Scale Edge Widths (Simple Version) |
|
| 533 |
#' |
|
| 534 |
#' Simple linear edge width scaling used by sn_edges() when width="weight". |
|
| 535 |
#' For the full-featured version with multiple modes and cut parameter, |
|
| 536 |
#' see scale_edge_widths() in scale-constants.R. |
|
| 537 |
#' |
|
| 538 |
#' @param values Numeric values to scale. |
|
| 539 |
#' @param range Target width range (min, max). |
|
| 540 |
#' @param maximum Optional maximum value for scaling. If provided, this value |
|
| 541 |
#' maps to the max of range, and values above it are capped. |
|
| 542 |
#' @return Scaled width values. |
|
| 543 |
#' @keywords internal |
|
| 544 |
scale_edge_widths_simple <- function(values, range = c(0.5, 3), maximum = NULL) {
|
|
| 545 | 1x |
if (all(is.na(values))) return(rep(mean(range), length(values))) |
| 546 | ||
| 547 |
# Use maximum as the upper bound if provided |
|
| 548 | 5x |
if (!is.null(maximum)) {
|
| 549 | 1x |
val_min <- 0 |
| 550 | 1x |
val_max <- maximum |
| 551 |
# Cap values at maximum |
|
| 552 | 1x |
values <- pmin(values, maximum) |
| 553 |
} else {
|
|
| 554 | 4x |
val_min <- min(values, na.rm = TRUE) |
| 555 | 4x |
val_max <- max(values, na.rm = TRUE) |
| 556 |
} |
|
| 557 | ||
| 558 | 5x |
if (val_max == val_min) {
|
| 559 | 1x |
return(rep(mean(range), length(values))) |
| 560 |
} |
|
| 561 | ||
| 562 |
# Linear scaling |
|
| 563 | 4x |
scaled <- (values - val_min) / (val_max - val_min) |
| 564 | 4x |
range[1] + scaled * diff(range) |
| 565 |
} |
|
| 566 | ||
| 567 |
#' Map Edge Colors by Weight |
|
| 568 |
#' |
|
| 569 |
#' Map edge colors based on weight values. |
|
| 570 |
#' |
|
| 571 |
#' @param weights Numeric weight values. |
|
| 572 |
#' @param positive_color Color for positive weights. |
|
| 573 |
#' @param negative_color Color for negative weights. |
|
| 574 |
#' @param zero_color Color for zero weights. |
|
| 575 |
#' @return Character vector of colors. |
|
| 576 |
#' @keywords internal |
|
| 577 |
map_edge_colors <- function(weights, positive_color = "#2E7D32", |
|
| 578 |
negative_color = "#C62828", |
|
| 579 |
zero_color = "gray50") {
|
|
| 580 | 1x |
colors <- character(length(weights)) |
| 581 | 1x |
colors[weights > 0] <- positive_color |
| 582 | 1x |
colors[weights < 0] <- negative_color |
| 583 | 1x |
colors[weights == 0] <- zero_color |
| 584 | 1x |
colors[is.na(weights)] <- zero_color |
| 585 | 1x |
colors |
| 586 |
} |
| 1 |
#' @title Main Entry Point |
|
| 2 |
#' @description The primary function for creating network visualizations. |
|
| 3 |
#' @keywords internal |
|
| 4 |
#' @name cograph-main |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Auto-convert input to cograph_network |
|
| 8 |
#' |
|
| 9 |
#' Internal helper that converts matrices, data frames, igraph, network, |
|
| 10 |
#' qgraph, or tna objects to cograph_network objects automatically. |
|
| 11 |
#' Works with both the old R6-based format and the new lightweight format. |
|
| 12 |
#' |
|
| 13 |
#' @param x Input object (matrix, data.frame, igraph, network, qgraph, tna, or cograph_network). |
|
| 14 |
#' @param layout Default layout to use if converting. |
|
| 15 |
#' @param seed Random seed for deterministic layouts. |
|
| 16 |
#' @param ... Additional arguments passed to cograph(). |
|
| 17 |
#' @return A cograph_network object. |
|
| 18 |
#' @noRd |
|
| 19 |
ensure_cograph_network <- function(x, layout = "spring", seed = 42, ...) {
|
|
| 20 | ||
| 21 | 2838x |
if (inherits(x, "cograph_network")) {
|
| 22 |
# Check if this is a new lightweight format without layout |
|
| 23 |
# Use getter function to get nodes |
|
| 24 | 1773x |
nodes <- get_nodes(x) |
| 25 | 1773x |
if (!is.null(nodes) && (!"x" %in% names(nodes) || all(is.na(nodes$x)))) {
|
| 26 |
# Need to compute layout for the new format |
|
| 27 | 16x |
x <- compute_layout_for_cograph(x, layout = layout, seed = seed, ...) |
| 28 |
} |
|
| 29 | 1773x |
return(x) |
| 30 |
} |
|
| 31 | ||
| 32 | 1065x |
if (is.matrix(x) || is.data.frame(x) || inherits(x, "igraph") || |
| 33 | 1065x |
inherits(x, "network") || inherits(x, "qgraph") || inherits(x, "tna")) {
|
| 34 | 1061x |
return(cograph(x, layout = layout, seed = seed, ...)) |
| 35 |
} |
|
| 36 | ||
| 37 | 4x |
stop("Input must be a matrix, data.frame, igraph, network, qgraph, tna, or cograph_network",
|
| 38 | 4x |
call. = FALSE) |
| 39 |
} |
|
| 40 | ||
| 41 |
#' Compute layout for lightweight cograph_network |
|
| 42 |
#' |
|
| 43 |
#' Computes layout coordinates for a cograph_network object that doesn't have them. |
|
| 44 |
#' |
|
| 45 |
#' @param net A cograph_network object (new lightweight format). |
|
| 46 |
#' @param layout Layout algorithm name. |
|
| 47 |
#' @param seed Random seed for deterministic layouts. |
|
| 48 |
#' @param ... Additional arguments passed to the layout function. |
|
| 49 |
#' @return The cograph_network with layout coordinates added. |
|
| 50 |
#' @noRd |
|
| 51 |
compute_layout_for_cograph <- function(net, layout = "spring", seed = 42, ...) {
|
|
| 52 |
# Get nodes data frame using getter function |
|
| 53 | 30x |
nodes <- get_nodes(net) |
| 54 | 30x |
n <- nrow(nodes) |
| 55 | ||
| 56 |
# Set seed for deterministic layouts |
|
| 57 | 30x |
if (!is.null(seed)) {
|
| 58 | 30x |
set.seed(seed) |
| 59 |
} |
|
| 60 | ||
| 61 |
# Two-letter igraph layout codes |
|
| 62 | 30x |
igraph_codes <- c("kk", "fr", "drl", "mds", "go", "tr", "st", "gr", "rd", "ni", "ci", "lgl", "sp")
|
| 63 | ||
| 64 |
# Build edges for layout computation using getter function |
|
| 65 | 30x |
edges <- get_edges(net) |
| 66 | ||
| 67 |
# Get directed status |
|
| 68 | 30x |
net_directed <- is_directed(net) |
| 69 | ||
| 70 |
# Compute layout |
|
| 71 | 30x |
if (is.function(layout)) {
|
| 72 |
# Need to create a temporary R6 network for igraph layout |
|
| 73 | 3x |
temp_net <- CographNetwork$new() |
| 74 | 3x |
temp_net$set_nodes(nodes) |
| 75 | 3x |
temp_net$set_edges(edges) |
| 76 | 3x |
temp_net$set_directed(net_directed) |
| 77 | 3x |
coords <- apply_igraph_layout(temp_net, layout, ...) |
| 78 | 27x |
} else if (is.character(layout) && ( |
| 79 | 27x |
grepl("^(igraph_|layout_)", layout) || layout %in% igraph_codes
|
| 80 |
)) {
|
|
| 81 |
# igraph layout by name |
|
| 82 | 7x |
temp_net <- CographNetwork$new() |
| 83 | 7x |
temp_net$set_nodes(nodes) |
| 84 | 7x |
temp_net$set_edges(edges) |
| 85 | 7x |
temp_net$set_directed(net_directed) |
| 86 | 7x |
coords <- apply_igraph_layout_by_name(temp_net, layout, seed = seed, ...) |
| 87 | 20x |
} else if (is.matrix(layout) || is.data.frame(layout)) {
|
| 88 |
# Custom coordinates |
|
| 89 | 2x |
coords <- as.data.frame(layout) |
| 90 | 2x |
if (ncol(coords) >= 2) {
|
| 91 | 2x |
names(coords)[1:2] <- c("x", "y")
|
| 92 |
} |
|
| 93 |
} else {
|
|
| 94 |
# Built-in cograph layout - create temporary network |
|
| 95 | 18x |
temp_net <- CographNetwork$new() |
| 96 | 18x |
temp_net$set_nodes(nodes) |
| 97 | 18x |
temp_net$set_edges(edges) |
| 98 | 18x |
temp_net$set_directed(net_directed) |
| 99 | 18x |
layout_obj <- CographLayout$new(layout, ...) |
| 100 | 18x |
coords <- layout_obj$compute(temp_net, ...) |
| 101 |
} |
|
| 102 | ||
| 103 |
# Update nodes with layout coordinates |
|
| 104 | 30x |
nodes$x <- coords$x |
| 105 | 30x |
nodes$y <- coords$y |
| 106 | ||
| 107 |
# Update using setter function or direct assignment for new format |
|
| 108 | 30x |
net$nodes <- nodes |
| 109 | 30x |
net$layout <- coords |
| 110 | 30x |
net$layout_info <- list( |
| 111 | 30x |
name = if (is.function(layout)) "custom_function" else as.character(layout), |
| 112 | 30x |
seed = seed |
| 113 |
) |
|
| 114 | ||
| 115 | 30x |
net |
| 116 |
} |
|
| 117 | ||
| 118 |
#' Create a Network Visualization |
|
| 119 |
#' |
|
| 120 |
#' The main entry point for cograph. Accepts adjacency matrices, edge lists, |
|
| 121 |
#' igraph, statnet network, qgraph, or tna objects and creates a visualization-ready |
|
| 122 |
#' network object. |
|
| 123 |
#' |
|
| 124 |
#' @param input Network input. Can be: |
|
| 125 |
#' - A square numeric matrix (adjacency/weight matrix) |
|
| 126 |
#' - A data frame with edge list (from, to, optional weight columns) |
|
| 127 |
#' - An igraph object |
|
| 128 |
#' - A statnet network object |
|
| 129 |
#' - A qgraph object |
|
| 130 |
#' - A tna object |
|
| 131 |
#' @param layout Layout algorithm: "circle", "spring", "groups", "grid", |
|
| 132 |
#' "random", "star", "bipartite", or "custom". Default "spring". |
|
| 133 |
#' @param directed Logical. Force directed interpretation. NULL for auto-detect. |
|
| 134 |
#' @param node_labels Character vector of node labels. |
|
| 135 |
#' @param seed Random seed for deterministic layouts. Default 42. Set NULL for random. |
|
| 136 |
#' @param ... Additional arguments passed to the layout function. |
|
| 137 |
#' |
|
| 138 |
#' @return A cograph_network object that can be further customized and rendered. |
|
| 139 |
#' |
|
| 140 |
#' @seealso |
|
| 141 |
#' \code{\link{splot}} for base R graphics rendering,
|
|
| 142 |
#' \code{\link{soplot}} for grid graphics rendering,
|
|
| 143 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 144 |
#' \code{\link{sn_edges}} for edge customization,
|
|
| 145 |
#' \code{\link{sn_layout}} for changing layouts,
|
|
| 146 |
#' \code{\link{sn_theme}} for visual themes,
|
|
| 147 |
#' \code{\link{sn_palette}} for color palettes,
|
|
| 148 |
#' \code{\link{from_qgraph}} and \code{\link{from_tna}} for converting external objects
|
|
| 149 |
#' |
|
| 150 |
#' @export |
|
| 151 |
#' |
|
| 152 |
#' @examples |
|
| 153 |
#' # From adjacency matrix |
|
| 154 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 155 |
#' cograph(adj) |
|
| 156 |
#' |
|
| 157 |
#' # From edge list |
|
| 158 |
#' edges <- data.frame(from = c(1, 1, 2), to = c(2, 3, 3)) |
|
| 159 |
#' cograph(edges) |
|
| 160 |
#' |
|
| 161 |
#' # With customization (pipe-friendly workflow) |
|
| 162 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 163 |
#' cograph(adj, layout = "circle") |> |
|
| 164 |
#' sn_nodes(fill = "steelblue") |> |
|
| 165 |
#' sn_edges(color = "gray50") |> |
|
| 166 |
#' splot() |
|
| 167 |
#' |
|
| 168 |
#' # Weighted network with automatic styling |
|
| 169 |
#' w_adj <- matrix(c(0, 0.5, -0.3, 0.5, 0, 0.4, -0.3, 0.4, 0), nrow = 3) |
|
| 170 |
#' cograph(w_adj) |> |
|
| 171 |
#' sn_edges(color = "weight", width = "weight") |> |
|
| 172 |
#' splot() |
|
| 173 |
#' |
|
| 174 |
#' # With igraph (if installed) |
|
| 175 |
#' \dontrun{
|
|
| 176 |
#' library(igraph) |
|
| 177 |
#' g <- make_ring(10) |
|
| 178 |
#' cograph(g) |> splot() |
|
| 179 |
#' } |
|
| 180 |
cograph <- function(input, layout = "spring", directed = NULL, |
|
| 181 |
node_labels = NULL, seed = 42, ...) {
|
|
| 182 | ||
| 183 |
# Create network object |
|
| 184 | 1552x |
network <- CographNetwork$new( |
| 185 | 1552x |
input = input, |
| 186 | 1552x |
directed = directed, |
| 187 | 1552x |
node_labels = node_labels |
| 188 |
) |
|
| 189 | ||
| 190 |
# Apply default theme |
|
| 191 | 1548x |
network$set_theme(get_theme("classic"))
|
| 192 | ||
| 193 |
# Set seed for deterministic layouts |
|
| 194 | 1548x |
if (!is.null(seed)) {
|
| 195 | 1547x |
set.seed(seed) |
| 196 |
} |
|
| 197 | ||
| 198 |
# Two-letter igraph layout codes |
|
| 199 | 1548x |
igraph_codes <- c("kk", "fr", "drl", "mds", "go", "tr", "st", "gr", "rd", "ni", "ci", "lgl", "sp")
|
| 200 | ||
| 201 |
# Compute layout - handle igraph layouts |
|
| 202 | 1548x |
if (is.function(layout)) {
|
| 203 |
# igraph layout function passed directly |
|
| 204 | 4x |
coords <- apply_igraph_layout(network, layout, ...) |
| 205 | 1544x |
} else if (is.character(layout) && ( |
| 206 | 1544x |
grepl("^(igraph_|layout_)", layout) || layout %in% igraph_codes
|
| 207 |
)) {
|
|
| 208 |
# igraph layout by name or two-letter code |
|
| 209 | 13x |
coords <- apply_igraph_layout_by_name(network, layout, seed = seed, ...) |
| 210 | 1531x |
} else if (is.matrix(layout) || is.data.frame(layout)) {
|
| 211 |
# Custom coordinates passed directly |
|
| 212 | 104x |
coords <- as.data.frame(layout) |
| 213 | 104x |
if (ncol(coords) >= 2) {
|
| 214 | 104x |
names(coords)[1:2] <- c("x", "y")
|
| 215 |
} |
|
| 216 |
} else {
|
|
| 217 |
# Built-in cograph layout |
|
| 218 | 1427x |
layout_obj <- CographLayout$new(layout, ...) |
| 219 | 1427x |
coords <- layout_obj$compute(network, ...) |
| 220 |
} |
|
| 221 | 1548x |
network$set_layout_coords(coords) |
| 222 | ||
| 223 |
# Store layout info |
|
| 224 | 1548x |
network$set_layout_info(list( |
| 225 | 1548x |
name = if (is.function(layout)) "custom_function" else as.character(layout), |
| 226 | 1548x |
seed = seed |
| 227 |
)) |
|
| 228 | ||
| 229 |
# Wrap in S3 class for method dispatch |
|
| 230 | 1548x |
as_cograph_network(network) |
| 231 |
} |
|
| 232 | ||
| 233 |
#' Apply Layout to Network |
|
| 234 |
#' |
|
| 235 |
#' Apply a layout algorithm to compute node positions. |
|
| 236 |
#' |
|
| 237 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 238 |
#' Matrices and other inputs are auto-converted. |
|
| 239 |
#' @param layout Layout algorithm name or a CographLayout object. |
|
| 240 |
#' @param seed Random seed for deterministic layouts. Default 42. Set NULL for random. |
|
| 241 |
#' @param ... Additional arguments passed to the layout function. |
|
| 242 |
#' |
|
| 243 |
#' @details |
|
| 244 |
#' ## Built-in Layouts |
|
| 245 |
#' \describe{
|
|
| 246 |
#' \item{\strong{spring}}{Force-directed layout (Fruchterman-Reingold style).
|
|
| 247 |
#' Good general-purpose layout. Default.} |
|
| 248 |
#' \item{\strong{circle}}{Nodes arranged in a circle. Good for small networks
|
|
| 249 |
#' or when structure is less important.} |
|
| 250 |
#' \item{\strong{groups}}{Circular layout with grouped nodes clustered together.}
|
|
| 251 |
#' \item{\strong{grid}}{Nodes in a regular grid.}
|
|
| 252 |
#' \item{\strong{random}}{Random positions. Useful as starting point.}
|
|
| 253 |
#' \item{\strong{star}}{Central node with others arranged around it.}
|
|
| 254 |
#' \item{\strong{bipartite}}{Two-column layout for bipartite networks.}
|
|
| 255 |
#' } |
|
| 256 |
#' |
|
| 257 |
#' ## igraph Layouts |
|
| 258 |
#' Two-letter codes for igraph layouts: "kk" (Kamada-Kawai), "fr" (Fruchterman-Reingold), |
|
| 259 |
#' "drl", "mds", "ni" (nicely), "tr" (tree), "ci" (circle), etc. |
|
| 260 |
#' |
|
| 261 |
#' You can also pass igraph layout functions directly or use full names like |
|
| 262 |
#' "layout_with_kk". |
|
| 263 |
#' |
|
| 264 |
#' @return Modified cograph_network object. |
|
| 265 |
#' |
|
| 266 |
#' @seealso |
|
| 267 |
#' \code{\link{cograph}} for network creation,
|
|
| 268 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 269 |
#' \code{\link{sn_edges}} for edge customization,
|
|
| 270 |
#' \code{\link{sn_theme}} for visual themes,
|
|
| 271 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting
|
|
| 272 |
#' |
|
| 273 |
#' @export |
|
| 274 |
#' |
|
| 275 |
#' @examples |
|
| 276 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 277 |
#' |
|
| 278 |
#' # Built-in layouts |
|
| 279 |
#' cograph(adj) |> sn_layout("circle") |> splot()
|
|
| 280 |
#' cograph(adj) |> sn_layout("spring") |> splot()
|
|
| 281 |
#' |
|
| 282 |
#' # igraph layouts (if igraph installed) |
|
| 283 |
#' \dontrun{
|
|
| 284 |
#' cograph(adj) |> sn_layout("kk") |> splot()
|
|
| 285 |
#' cograph(adj) |> sn_layout("fr") |> splot()
|
|
| 286 |
#' } |
|
| 287 |
#' |
|
| 288 |
#' # Custom coordinates |
|
| 289 |
#' coords <- matrix(c(0, 0, 1, 0, 0.5, 1), ncol = 2, byrow = TRUE) |
|
| 290 |
#' cograph(adj) |> sn_layout(coords) |> splot() |
|
| 291 |
#' |
|
| 292 |
#' # Direct matrix input (auto-converts) |
|
| 293 |
#' adj |> sn_layout("circle")
|
|
| 294 |
sn_layout <- function(network, layout, seed = 42, ...) {
|
|
| 295 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 296 | 179x |
network <- ensure_cograph_network(network, layout = layout, seed = seed, ...) |
| 297 | ||
| 298 | 179x |
new_net <- network$network$clone_network() |
| 299 | ||
| 300 |
# Set seed for deterministic layouts |
|
| 301 | 179x |
if (!is.null(seed)) {
|
| 302 | 179x |
set.seed(seed) |
| 303 |
} |
|
| 304 | ||
| 305 |
# Two-letter igraph layout codes |
|
| 306 | 179x |
igraph_codes <- c("kk", "fr", "drl", "mds", "go", "tr", "st", "gr", "rd", "ni", "ci", "lgl", "sp")
|
| 307 | ||
| 308 |
# Handle igraph layout functions |
|
| 309 | 179x |
if (is.function(layout)) {
|
| 310 |
# Assume it's an igraph layout function |
|
| 311 | 1x |
coords <- apply_igraph_layout(new_net, layout, ...) |
| 312 | 1x |
new_net$set_layout_coords(coords) |
| 313 | 1x |
new_net$set_layout_info(list(name = "custom_function", seed = seed, coords = coords)) |
| 314 | 1x |
return(as_cograph_network(new_net)) |
| 315 |
} |
|
| 316 | ||
| 317 |
# Create layout object if string |
|
| 318 | 178x |
if (is.character(layout)) {
|
| 319 |
# Check if it's an igraph layout name or two-letter code |
|
| 320 | 169x |
if (grepl("^(igraph_|layout_)", layout) || layout %in% igraph_codes) {
|
| 321 | 4x |
coords <- apply_igraph_layout_by_name(new_net, layout, seed = seed, ...) |
| 322 | 4x |
new_net$set_layout_coords(coords) |
| 323 | 4x |
new_net$set_layout_info(list(name = layout, seed = seed, coords = coords)) |
| 324 | 4x |
return(as_cograph_network(new_net)) |
| 325 |
} |
|
| 326 | 165x |
layout_obj <- CographLayout$new(layout, ...) |
| 327 | 9x |
} else if (inherits(layout, "CographLayout")) {
|
| 328 | 1x |
layout_obj <- layout |
| 329 | 8x |
} else if (is.matrix(layout) || is.data.frame(layout)) {
|
| 330 |
# Custom coordinates passed directly |
|
| 331 | 6x |
coords <- as.data.frame(layout) |
| 332 | 6x |
if (ncol(coords) >= 2) {
|
| 333 | 6x |
names(coords)[1:2] <- c("x", "y")
|
| 334 |
} |
|
| 335 | 6x |
new_net$set_layout_coords(coords) |
| 336 | 6x |
new_net$set_layout_info(list(name = "custom", seed = seed, coords = coords)) |
| 337 | 6x |
return(as_cograph_network(new_net)) |
| 338 |
} else {
|
|
| 339 | 2x |
stop("layout must be a string, CographLayout object, igraph layout function, or coordinate matrix",
|
| 340 | 2x |
call. = FALSE) |
| 341 |
} |
|
| 342 | ||
| 343 |
# Compute and apply coordinates |
|
| 344 | 166x |
coords <- layout_obj$compute(new_net, ...) |
| 345 | 165x |
new_net$set_layout_coords(coords) |
| 346 | 165x |
new_net$set_layout_info(list(name = layout, seed = seed, coords = coords)) |
| 347 | ||
| 348 | 165x |
as_cograph_network(new_net) |
| 349 |
} |
|
| 350 | ||
| 351 |
#' Apply Theme to Network |
|
| 352 |
#' |
|
| 353 |
#' Apply a visual theme to the network. |
|
| 354 |
#' |
|
| 355 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 356 |
#' Matrices and other inputs are auto-converted. |
|
| 357 |
#' @param theme Theme name (string) or CographTheme object. |
|
| 358 |
#' @param ... Additional theme parameters to override. |
|
| 359 |
#' |
|
| 360 |
#' @details |
|
| 361 |
#' ## Available Themes |
|
| 362 |
#' \describe{
|
|
| 363 |
#' \item{\strong{classic}}{Default theme with white background, blue nodes, gray edges.}
|
|
| 364 |
#' \item{\strong{dark}}{Dark background with light nodes. Good for presentations.}
|
|
| 365 |
#' \item{\strong{minimal}}{Subtle styling with thin edges and muted colors.}
|
|
| 366 |
#' \item{\strong{colorblind}}{Optimized for color vision deficiency.}
|
|
| 367 |
#' \item{\strong{grayscale}}{Black and white only.}
|
|
| 368 |
#' \item{\strong{vibrant}}{Bold, saturated colors.}
|
|
| 369 |
#' } |
|
| 370 |
#' |
|
| 371 |
#' Use \code{list_themes()} to see all available themes.
|
|
| 372 |
#' |
|
| 373 |
#' @return Modified cograph_network object. |
|
| 374 |
#' |
|
| 375 |
#' @seealso |
|
| 376 |
#' \code{\link{cograph}} for network creation,
|
|
| 377 |
#' \code{\link{sn_palette}} for color palettes,
|
|
| 378 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 379 |
#' \code{\link{sn_edges}} for edge customization,
|
|
| 380 |
#' \code{\link{list_themes}} to see available themes,
|
|
| 381 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting
|
|
| 382 |
#' |
|
| 383 |
#' @export |
|
| 384 |
#' |
|
| 385 |
#' @examples |
|
| 386 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 387 |
#' |
|
| 388 |
#' # Apply different themes |
|
| 389 |
#' cograph(adj) |> sn_theme("dark") |> splot()
|
|
| 390 |
#' cograph(adj) |> sn_theme("minimal") |> splot()
|
|
| 391 |
#' |
|
| 392 |
#' # Override specific theme properties |
|
| 393 |
#' cograph(adj) |> sn_theme("classic", background = "lightgray") |> splot()
|
|
| 394 |
#' |
|
| 395 |
#' # Direct matrix input |
|
| 396 |
#' adj |> sn_theme("dark")
|
|
| 397 |
sn_theme <- function(network, theme, ...) {
|
|
| 398 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 399 | 66x |
network <- ensure_cograph_network(network) |
| 400 | ||
| 401 | 66x |
new_net <- network$network$clone_network() |
| 402 | ||
| 403 |
# Get theme object |
|
| 404 | 66x |
if (is.character(theme)) {
|
| 405 | 60x |
theme_obj <- get_theme(theme) |
| 406 | 60x |
if (is.null(theme_obj)) {
|
| 407 | 3x |
stop("Unknown theme: ", theme, ". Available: ",
|
| 408 | 3x |
paste(list_themes(), collapse = ", "), call. = FALSE) |
| 409 |
} |
|
| 410 | 6x |
} else if (inherits(theme, "CographTheme")) {
|
| 411 | 2x |
theme_obj <- theme |
| 412 |
} else {
|
|
| 413 | 4x |
stop("theme must be a string or CographTheme object", call. = FALSE)
|
| 414 |
} |
|
| 415 | ||
| 416 |
# Apply overrides |
|
| 417 | 59x |
overrides <- list(...) |
| 418 | 59x |
if (length(overrides) > 0) {
|
| 419 | 3x |
theme_obj <- theme_obj$merge(overrides) |
| 420 |
} |
|
| 421 | ||
| 422 | 59x |
new_net$set_theme(theme_obj) |
| 423 | ||
| 424 | 59x |
as_cograph_network(new_net) |
| 425 |
} |
|
| 426 | ||
| 427 |
#' Apply Color Palette to Network |
|
| 428 |
#' |
|
| 429 |
#' Apply a color palette for node and/or edge coloring. |
|
| 430 |
#' |
|
| 431 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 432 |
#' Matrices and other inputs are auto-converted. |
|
| 433 |
#' @param palette Palette name or function. |
|
| 434 |
#' @param target What to apply the palette to: "nodes", "edges", or "both". |
|
| 435 |
#' @param by Variable to map colors to (for nodes: column name or "group"). |
|
| 436 |
#' |
|
| 437 |
#' @details |
|
| 438 |
#' ## Available Palettes |
|
| 439 |
#' Use \code{list_palettes()} to see all available palettes. Common options:
|
|
| 440 |
#' \describe{
|
|
| 441 |
#' \item{\strong{viridis}}{Perceptually uniform, colorblind-friendly.}
|
|
| 442 |
#' \item{\strong{colorblind}}{Optimized for color vision deficiency.}
|
|
| 443 |
#' \item{\strong{pastel}}{Soft, muted colors.}
|
|
| 444 |
#' \item{\strong{bright}}{Saturated, vivid colors.}
|
|
| 445 |
#' \item{\strong{grayscale}}{Shades of gray.}
|
|
| 446 |
#' } |
|
| 447 |
#' |
|
| 448 |
#' You can also pass a custom palette function that takes \code{n} and returns
|
|
| 449 |
#' \code{n} colors.
|
|
| 450 |
#' |
|
| 451 |
#' @return Modified cograph_network object. |
|
| 452 |
#' |
|
| 453 |
#' @seealso |
|
| 454 |
#' \code{\link{cograph}} for network creation,
|
|
| 455 |
#' \code{\link{sn_theme}} for visual themes,
|
|
| 456 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 457 |
#' \code{\link{list_palettes}} to see available palettes,
|
|
| 458 |
#' \code{\link{splot}} and \code{\link{soplot}} for plotting
|
|
| 459 |
#' |
|
| 460 |
#' @export |
|
| 461 |
#' |
|
| 462 |
#' @examples |
|
| 463 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 464 |
#' |
|
| 465 |
#' # Apply palette to nodes |
|
| 466 |
#' cograph(adj) |> sn_palette("viridis") |> splot()
|
|
| 467 |
#' |
|
| 468 |
#' # Apply to edges |
|
| 469 |
#' cograph(adj) |> sn_palette("colorblind", target = "edges") |> splot()
|
|
| 470 |
#' |
|
| 471 |
#' # Apply to both |
|
| 472 |
#' cograph(adj) |> sn_palette("pastel", target = "both") |> splot()
|
|
| 473 |
#' |
|
| 474 |
#' # Custom palette function |
|
| 475 |
#' my_pal <- function(n) rainbow(n, s = 0.7) |
|
| 476 |
#' cograph(adj) |> sn_palette(my_pal) |> splot() |
|
| 477 |
#' |
|
| 478 |
#' # Direct matrix input |
|
| 479 |
#' adj |> sn_palette("viridis")
|
|
| 480 |
sn_palette <- function(network, palette, target = "nodes", by = NULL) {
|
|
| 481 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 482 | 27x |
network <- ensure_cograph_network(network) |
| 483 | ||
| 484 | 27x |
new_net <- network$network$clone_network() |
| 485 | ||
| 486 |
# Get palette function |
|
| 487 | 27x |
if (is.character(palette)) {
|
| 488 | 23x |
pal_fn <- get_palette(palette) |
| 489 | 23x |
if (is.null(pal_fn)) {
|
| 490 | 3x |
stop("Unknown palette: ", palette, ". Available: ",
|
| 491 | 3x |
paste(list_palettes(), collapse = ", "), call. = FALSE) |
| 492 |
} |
|
| 493 | 4x |
} else if (is.function(palette)) {
|
| 494 | 2x |
pal_fn <- palette |
| 495 |
} else {
|
|
| 496 | 2x |
stop("palette must be a string or function", call. = FALSE)
|
| 497 |
} |
|
| 498 | ||
| 499 |
# Apply to nodes |
|
| 500 | 22x |
if (target %in% c("nodes", "both")) {
|
| 501 | 20x |
n <- new_net$n_nodes |
| 502 | 20x |
nodes_df <- new_net$get_nodes() |
| 503 | ||
| 504 | 20x |
if (!is.null(by) && by %in% names(nodes_df)) {
|
| 505 |
# Map by variable |
|
| 506 | 1x |
colors <- scale_color_discrete(nodes_df[[by]], pal_fn) |
| 507 |
} else {
|
|
| 508 |
# Default: all same color (first from palette) |
|
| 509 | 19x |
colors <- rep(pal_fn(1), n) |
| 510 |
} |
|
| 511 | ||
| 512 | 20x |
new_net$set_node_aes(list(fill = colors)) |
| 513 |
} |
|
| 514 | ||
| 515 |
# Apply to edges |
|
| 516 | 22x |
if (target %in% c("edges", "both")) {
|
| 517 | 4x |
edges_df <- new_net$get_edges() |
| 518 | 4x |
if (!is.null(edges_df) && nrow(edges_df) > 0) {
|
| 519 |
# Use first two colors for positive/negative |
|
| 520 | 4x |
edge_colors <- pal_fn(2) |
| 521 | 4x |
new_net$set_edge_aes(list( |
| 522 | 4x |
positive_color = edge_colors[1], |
| 523 | 4x |
negative_color = edge_colors[2] |
| 524 |
)) |
|
| 525 |
} |
|
| 526 |
} |
|
| 527 | ||
| 528 | 22x |
as_cograph_network(new_net) |
| 529 |
} |
| 1 |
#' @title Print Methods |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description S3 print methods for Cograph objects. |
|
| 4 |
#' @name methods-print |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Print cograph_network Object |
|
| 8 |
#' |
|
| 9 |
#' @param x A cograph_network object. |
|
| 10 |
#' @param ... Ignored. |
|
| 11 |
#' @keywords internal |
|
| 12 |
#' @return Invisible x. |
|
| 13 |
#' @export |
|
| 14 |
print.cograph_network <- function(x, ...) {
|
|
| 15 |
# Handle new list-based format (has n_nodes as list element) |
|
| 16 | 31x |
if (!is.null(x$n_nodes)) {
|
| 17 | 14x |
n <- x$n_nodes |
| 18 | 14x |
e <- x$n_edges |
| 19 | 14x |
dir <- x$directed |
| 20 | 14x |
dir_str <- if (isTRUE(dir)) "directed" else "undirected" |
| 21 | ||
| 22 | 14x |
cat("Cograph network:", n, "nodes,", e, "edges (", dir_str, ")\n", sep = " ")
|
| 23 | ||
| 24 |
# Show weight range if there are edges |
|
| 25 | 14x |
if (e > 0 && !is.null(x$weight)) {
|
| 26 | 7x |
w_range <- range(x$weight, na.rm = TRUE) |
| 27 | 7x |
if (w_range[1] != w_range[2]) {
|
| 28 | 2x |
cat("Weights:", round(w_range[1], 3), "to", round(w_range[2], 3), "\n")
|
| 29 |
} else {
|
|
| 30 | 5x |
cat("Weights:", round(w_range[1], 3), "(all equal)\n")
|
| 31 |
} |
|
| 32 |
} |
|
| 33 | ||
| 34 |
# Show layout status |
|
| 35 | 14x |
nodes_df <- x$nodes |
| 36 | 14x |
has_layout <- !is.null(nodes_df) && "x" %in% names(nodes_df) && !all(is.na(nodes_df$x)) |
| 37 | 14x |
cat("Layout:", if (has_layout) "set" else "none", "\n")
|
| 38 | ||
| 39 | 14x |
return(invisible(x)) |
| 40 |
} |
|
| 41 | ||
| 42 |
# Handle old attr-based format (for backward compatibility) |
|
| 43 | 17x |
if (!is.null(attr(x, "n_nodes"))) {
|
| 44 | 6x |
n <- attr(x, "n_nodes") |
| 45 | 6x |
e <- attr(x, "n_edges") |
| 46 | 6x |
dir <- attr(x, "directed") |
| 47 | 6x |
dir_str <- if (isTRUE(dir)) "directed" else "undirected" |
| 48 | ||
| 49 | 6x |
cat("Cograph network:", n, "nodes,", e, "edges (", dir_str, ")\n", sep = " ")
|
| 50 | ||
| 51 |
# Show weight range if there are edges |
|
| 52 | 6x |
if (e > 0 && !is.null(x$weight)) {
|
| 53 | 2x |
w_range <- range(x$weight, na.rm = TRUE) |
| 54 | 2x |
if (w_range[1] != w_range[2]) {
|
| 55 | 1x |
cat("Weights:", round(w_range[1], 3), "to", round(w_range[2], 3), "\n")
|
| 56 |
} else {
|
|
| 57 | 1x |
cat("Weights:", round(w_range[1], 3), "(all equal)\n")
|
| 58 |
} |
|
| 59 |
} |
|
| 60 | ||
| 61 |
# Show layout status |
|
| 62 | 6x |
nodes_df <- attr(x, "nodes") |
| 63 | 6x |
has_layout <- !is.null(nodes_df) && "x" %in% names(nodes_df) && !all(is.na(nodes_df$x)) |
| 64 | 6x |
cat("Layout:", if (has_layout) "set" else "none", "\n")
|
| 65 | ||
| 66 | 6x |
return(invisible(x)) |
| 67 |
} |
|
| 68 | ||
| 69 |
# Handle old R6 wrapper format |
|
| 70 | 11x |
net <- x$network |
| 71 | 11x |
if (!is.null(net) && inherits(net, "CographNetwork")) {
|
| 72 | 10x |
cat("Cograph Network\n")
|
| 73 | 10x |
cat("==============\n")
|
| 74 | 10x |
cat("Nodes:", net$n_nodes, "\n")
|
| 75 | 10x |
cat("Edges:", net$n_edges, "\n")
|
| 76 | 10x |
cat("Directed:", net$is_directed, "\n")
|
| 77 | 10x |
cat("Weighted:", net$has_weights, "\n")
|
| 78 | ||
| 79 | 10x |
layout <- net$get_layout() |
| 80 | 10x |
cat("Layout:", if (is.null(layout)) "not computed" else "computed", "\n")
|
| 81 | ||
| 82 | 10x |
theme <- net$get_theme() |
| 83 | 10x |
cat("Theme:", if (is.null(theme)) "none" else theme$name, "\n")
|
| 84 | ||
| 85 | 10x |
cat("\nUse plot() or sn_render() to visualize\n")
|
| 86 | 10x |
cat("Use sn_ggplot() to convert to ggplot2\n")
|
| 87 | ||
| 88 | 10x |
return(invisible(x)) |
| 89 |
} |
|
| 90 | ||
| 91 |
# Fallback |
|
| 92 | 1x |
cat("Cograph network object\n")
|
| 93 | 1x |
invisible(x) |
| 94 |
} |
| 1 |
#' @title Theme Registry Functions |
|
| 2 |
#' @description Functions for registering built-in themes. |
|
| 3 |
#' @name themes-registry |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Register Built-in Themes |
|
| 8 |
#' |
|
| 9 |
#' Register all built-in themes. |
|
| 10 |
#' |
|
| 11 |
#' @keywords internal |
|
| 12 |
register_builtin_themes <- function() {
|
|
| 13 | 2x |
register_theme("classic", theme_cograph_classic())
|
| 14 | 2x |
register_theme("colorblind", theme_cograph_colorblind())
|
| 15 | 2x |
register_theme("gray", theme_cograph_gray())
|
| 16 | 2x |
register_theme("grey", theme_cograph_gray()) # Alias
|
| 17 | 2x |
register_theme("dark", theme_cograph_dark())
|
| 18 | 2x |
register_theme("minimal", theme_cograph_minimal())
|
| 19 | 2x |
register_theme("viridis", theme_cograph_viridis())
|
| 20 | 2x |
register_theme("nature", theme_cograph_nature())
|
| 21 |
} |
| 1 |
#' @title Plot Methods |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description S3 plot methods for Cograph objects. |
|
| 4 |
#' @name methods-plot |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Plot cograph_network Object |
|
| 8 |
#' |
|
| 9 |
#' @param x A cograph_network object. |
|
| 10 |
#' @param ... Additional arguments passed to sn_render. |
|
| 11 |
#' @keywords internal |
|
| 12 |
#' @return Invisible x. |
|
| 13 |
#' @export |
|
| 14 |
#' |
|
| 15 |
#' @examples |
|
| 16 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 17 |
#' net <- cograph(adj) |
|
| 18 |
#' plot(net) |
|
| 19 |
plot.cograph_network <- function(x, ...) {
|
|
| 20 | 1x |
sn_render(x, ...) |
| 21 | 1x |
invisible(x) |
| 22 |
} |
|
| 23 | ||
| 24 |
#' Summary of cograph_network Object |
|
| 25 |
#' |
|
| 26 |
#' @param object A cograph_network object. |
|
| 27 |
#' @keywords internal |
|
| 28 |
#' @param ... Ignored. |
|
| 29 |
#' @return A list with network summary information (invisibly). |
|
| 30 |
#' @export |
|
| 31 |
summary.cograph_network <- function(object, ...) {
|
|
| 32 | 7x |
net <- object$network |
| 33 | 7x |
nodes <- net$get_nodes() |
| 34 | 7x |
edges <- net$get_edges() |
| 35 | ||
| 36 | 7x |
cat("Cograph Network Summary\n")
|
| 37 | 7x |
cat("======================\n\n")
|
| 38 | ||
| 39 | 7x |
cat("Structure:\n")
|
| 40 | 7x |
cat(" Nodes:", net$n_nodes, "\n")
|
| 41 | 7x |
cat(" Edges:", net$n_edges, "\n")
|
| 42 | 7x |
cat(" Type:", if (net$is_directed) "Directed" else "Undirected", "\n")
|
| 43 | ||
| 44 | 7x |
if (!is.null(edges) && nrow(edges) > 0) {
|
| 45 | 7x |
cat("\nEdge Statistics:\n")
|
| 46 | 7x |
if (!is.null(edges$weight)) {
|
| 47 | 7x |
cat(" Min weight:", round(min(edges$weight), 3), "\n")
|
| 48 | 7x |
cat(" Max weight:", round(max(edges$weight), 3), "\n")
|
| 49 | 7x |
cat(" Mean weight:", round(mean(edges$weight), 3), "\n")
|
| 50 | 7x |
n_pos <- sum(edges$weight > 0) |
| 51 | 7x |
n_neg <- sum(edges$weight < 0) |
| 52 | 7x |
if (n_neg > 0) {
|
| 53 | 1x |
cat(" Positive edges:", n_pos, "\n")
|
| 54 | 1x |
cat(" Negative edges:", n_neg, "\n")
|
| 55 |
} |
|
| 56 |
} |
|
| 57 |
} |
|
| 58 | ||
| 59 | 7x |
if (net$n_nodes > 0) {
|
| 60 | 7x |
cat("\nNode Labels:\n")
|
| 61 | 7x |
labels <- net$node_labels |
| 62 | 7x |
if (length(labels) > 10) {
|
| 63 | 1x |
cat(" ", paste(labels[1:10], collapse = ", "), ", ...\n")
|
| 64 |
} else {
|
|
| 65 | 6x |
cat(" ", paste(labels, collapse = ", "), "\n")
|
| 66 |
} |
|
| 67 |
} |
|
| 68 | ||
| 69 | 7x |
cat("\nLayout:", if (is.null(net$get_layout())) "not computed" else "computed", "\n")
|
| 70 | ||
| 71 | 7x |
theme <- net$get_theme() |
| 72 | 7x |
cat("Theme:", if (is.null(theme)) "none" else theme$name, "\n")
|
| 73 | ||
| 74 | 7x |
invisible(list( |
| 75 | 7x |
n_nodes = net$n_nodes, |
| 76 | 7x |
n_edges = net$n_edges, |
| 77 | 7x |
directed = net$is_directed, |
| 78 | 7x |
weighted = net$has_weights, |
| 79 | 7x |
has_layout = !is.null(net$get_layout()) |
| 80 |
)) |
|
| 81 |
} |
| 1 |
#' @title Node Rendering |
|
| 2 |
#' @description Functions for rendering nodes using grid graphics. |
|
| 3 |
#' @name render-nodes |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Render All Nodes |
|
| 8 |
#' |
|
| 9 |
#' Create grid grobs for all nodes in the network. |
|
| 10 |
#' |
|
| 11 |
#' @param network A CographNetwork object. |
|
| 12 |
#' @return A grid gList of node grobs. |
|
| 13 |
#' @keywords internal |
|
| 14 |
render_nodes_grid <- function(network) {
|
|
| 15 | 519x |
nodes <- network$get_nodes() |
| 16 | 519x |
aes <- network$get_node_aes() |
| 17 | 519x |
theme <- network$get_theme() |
| 18 | 519x |
n <- nrow(nodes) |
| 19 | ||
| 20 | 1x |
if (n == 0) return(grid::gList()) |
| 21 | ||
| 22 |
# Resolve aesthetics to per-node values |
|
| 23 |
# Default node size uses scale constants: node_default * soplot_node_factor |
|
| 24 | 518x |
default_node_size <- COGRAPH_SCALE$node_default * COGRAPH_SCALE$soplot_node_factor |
| 25 | 518x |
sizes <- expand_param( |
| 26 | 518x |
if (!is.null(aes$size)) aes$size else default_node_size, |
| 27 | 518x |
n, "node_size" |
| 28 |
) |
|
| 29 | 518x |
shapes <- expand_param( |
| 30 | 518x |
if (!is.null(aes$shape)) aes$shape else "circle", |
| 31 | 518x |
n, "node_shape" |
| 32 |
) |
|
| 33 | 518x |
fills <- expand_param( |
| 34 | 518x |
if (!is.null(aes$fill)) aes$fill else theme$get("node_fill"),
|
| 35 | 518x |
n, "node_fill" |
| 36 |
) |
|
| 37 | 518x |
border_colors <- expand_param( |
| 38 | 518x |
if (!is.null(aes$border_color)) aes$border_color else theme$get("node_border"),
|
| 39 | 518x |
n, "node_border_color" |
| 40 |
) |
|
| 41 | 518x |
border_widths <- expand_param( |
| 42 | 518x |
if (!is.null(aes$border_width)) aes$border_width else theme$get("node_border_width"),
|
| 43 | 518x |
n, "node_border_width" |
| 44 |
) |
|
| 45 | 518x |
alphas <- expand_param( |
| 46 | 518x |
if (!is.null(aes$alpha)) aes$alpha else 1, |
| 47 | 518x |
n, "node_alpha" |
| 48 |
) |
|
| 49 | ||
| 50 |
# Vectorize donut parameters (strict: length 1 or n) |
|
| 51 | 518x |
donut_inner_ratios <- expand_param( |
| 52 | 518x |
if (!is.null(aes$donut_inner_ratio)) aes$donut_inner_ratio else 0.5, |
| 53 | 518x |
n, "donut_inner_ratio" |
| 54 |
) |
|
| 55 | 518x |
donut_bg_colors <- expand_param( |
| 56 | 518x |
if (!is.null(aes$donut_bg_color)) aes$donut_bg_color else "gray90", |
| 57 | 518x |
n, "donut_bg_color" |
| 58 |
) |
|
| 59 | 518x |
donut_show_values <- expand_param( |
| 60 | 518x |
if (!is.null(aes$donut_show_value)) aes$donut_show_value else FALSE, |
| 61 | 518x |
n, "donut_show_value" |
| 62 |
) |
|
| 63 | 518x |
donut_value_sizes <- expand_param( |
| 64 | 518x |
if (!is.null(aes$donut_value_size)) aes$donut_value_size else 8, |
| 65 | 518x |
n, "donut_value_size" |
| 66 |
) |
|
| 67 | 518x |
donut_value_colors <- expand_param( |
| 68 | 518x |
if (!is.null(aes$donut_value_color)) aes$donut_value_color else "black", |
| 69 | 518x |
n, "donut_value_color" |
| 70 |
) |
|
| 71 | 518x |
donut_value_fontfaces <- expand_param( |
| 72 | 518x |
if (!is.null(aes$donut_value_fontface)) aes$donut_value_fontface else "bold", |
| 73 | 518x |
n, "donut_value_fontface" |
| 74 |
) |
|
| 75 | 518x |
donut_value_fontfamilies <- expand_param( |
| 76 | 518x |
if (!is.null(aes$donut_value_fontfamily)) aes$donut_value_fontfamily else "sans", |
| 77 | 518x |
n, "donut_value_fontfamily" |
| 78 |
) |
|
| 79 | ||
| 80 |
# Create grobs for each node |
|
| 81 | 518x |
grobs <- vector("list", n)
|
| 82 | 518x |
for (i in seq_len(n)) {
|
| 83 | 1947x |
shape_fn <- get_shape(shapes[i]) |
| 84 | 1947x |
if (is.null(shape_fn)) {
|
| 85 | 3x |
shape_fn <- get_shape("circle")
|
| 86 |
} |
|
| 87 | ||
| 88 |
# Additional arguments for special shapes |
|
| 89 | 1947x |
extra_args <- list() |
| 90 | ||
| 91 |
# Check if this node should render as a donut (based on donut_values) |
|
| 92 | 1947x |
has_donut_value <- !is.null(aes$donut_values) && length(aes$donut_values) >= i && |
| 93 | 1947x |
!is.null(aes$donut_values[[i]]) && !is.na(aes$donut_values[[i]]) |
| 94 | ||
| 95 |
# If donut_values is set for this node, render as donut (override shape) |
|
| 96 | 1947x |
if (has_donut_value && !shapes[i] %in% c("donut", "polygon_donut", "pie", "donut_pie", "double_donut_pie")) {
|
| 97 |
# Determine donut shape from aes$donut_shape |
|
| 98 | 64x |
effective_donut_shape <- if (!is.null(aes$donut_shape)) {
|
| 99 | 2x |
if (length(aes$donut_shape) >= i) aes$donut_shape[i] else aes$donut_shape[1] |
| 100 |
} else {
|
|
| 101 | 9x |
"circle" |
| 102 |
} |
|
| 103 | ||
| 104 |
# Use polygon_donut for non-circle shapes, regular donut for circles |
|
| 105 | 64x |
if (effective_donut_shape != "circle") {
|
| 106 | 34x |
shape_fn <- get_shape("polygon_donut")
|
| 107 | 34x |
extra_args$donut_shape <- effective_donut_shape |
| 108 |
} else {
|
|
| 109 | 30x |
shape_fn <- get_shape("donut")
|
| 110 |
} |
|
| 111 | ||
| 112 |
# Pass donut value |
|
| 113 | 64x |
extra_args$values <- aes$donut_values[[i]] |
| 114 | ||
| 115 |
# Pass donut colors |
|
| 116 | 64x |
if (!is.null(aes$donut_colors)) {
|
| 117 | 6x |
if (is.list(aes$donut_colors) && length(aes$donut_colors) >= i) {
|
| 118 | 3x |
extra_args$colors <- aes$donut_colors[[i]] |
| 119 | 3x |
} else if (!is.list(aes$donut_colors)) {
|
| 120 | 3x |
extra_args$colors <- aes$donut_colors[1] |
| 121 |
} |
|
| 122 |
} |
|
| 123 | ||
| 124 |
# Pass all donut parameters (using pre-vectorized per-node values) |
|
| 125 | 64x |
extra_args$inner_ratio <- donut_inner_ratios[i] |
| 126 | 64x |
extra_args$bg_color <- donut_bg_colors[i] |
| 127 | 64x |
extra_args$show_value <- donut_show_values[i] |
| 128 | 64x |
extra_args$value_size <- donut_value_sizes[i] |
| 129 | 64x |
extra_args$value_color <- donut_value_colors[i] |
| 130 | 64x |
extra_args$value_fontface <- donut_value_fontfaces[i] |
| 131 | 64x |
extra_args$value_fontfamily <- donut_value_fontfamilies[i] |
| 132 | 51x |
if (!is.null(aes$donut_value_digits)) extra_args$value_digits <- aes$donut_value_digits |
| 133 | 51x |
if (!is.null(aes$donut_value_prefix)) extra_args$value_prefix <- aes$donut_value_prefix |
| 134 | 51x |
if (!is.null(aes$donut_value_suffix)) extra_args$value_suffix <- aes$donut_value_suffix |
| 135 | 3x |
if (!is.null(aes$donut_border_width)) extra_args$donut_border_width <- aes$donut_border_width |
| 136 |
} |
|
| 137 | ||
| 138 | 1947x |
if (shapes[i] %in% c("pie", "donut") && !is.null(aes$pie_values)) {
|
| 139 | 15x |
if (is.list(aes$pie_values)) {
|
| 140 | 9x |
extra_args$values <- aes$pie_values[[i]] |
| 141 | 6x |
} else if (is.matrix(aes$pie_values)) {
|
| 142 | 3x |
extra_args$values <- aes$pie_values[i, ] |
| 143 | 3x |
} else if (is.numeric(aes$pie_values)) {
|
| 144 |
# Single values per node (for donut) |
|
| 145 | 3x |
extra_args$values <- aes$pie_values[i] |
| 146 |
} |
|
| 147 | 15x |
if (!is.null(aes$pie_colors)) {
|
| 148 | 6x |
extra_args$colors <- aes$pie_colors |
| 149 |
} |
|
| 150 |
} |
|
| 151 |
# Pie-specific border width |
|
| 152 | 1947x |
if (shapes[i] == "pie" && !is.null(aes$pie_border_width)) {
|
| 153 | 3x |
extra_args$pie_border_width <- aes$pie_border_width |
| 154 |
} |
|
| 155 |
# Donut-specific parameters |
|
| 156 | 1947x |
if (shapes[i] == "donut" || shapes[i] == "polygon_donut") {
|
| 157 |
# Pass donut_values as values (for explicit donut shapes) |
|
| 158 | 78x |
if (!is.null(aes$donut_values) && length(aes$donut_values) >= i && |
| 159 | 78x |
!is.null(aes$donut_values[[i]]) && !is.na(aes$donut_values[[i]])) {
|
| 160 | 75x |
extra_args$values <- aes$donut_values[[i]] |
| 161 |
} else {
|
|
| 162 |
# Default to 1.0 (fully filled) for explicit donut shapes without values |
|
| 163 | 3x |
extra_args$values <- 1.0 |
| 164 |
} |
|
| 165 |
# Pass donut_colors as colors |
|
| 166 | 78x |
if (!is.null(aes$donut_colors)) {
|
| 167 | 6x |
if (is.list(aes$donut_colors) && length(aes$donut_colors) >= i) {
|
| 168 | 3x |
extra_args$colors <- aes$donut_colors[[i]] |
| 169 | 3x |
} else if (!is.list(aes$donut_colors)) {
|
| 170 | 3x |
extra_args$colors <- aes$donut_colors[1] |
| 171 |
} |
|
| 172 |
} |
|
| 173 |
# Use pre-vectorized per-node values |
|
| 174 | 78x |
extra_args$inner_ratio <- donut_inner_ratios[i] |
| 175 | 78x |
extra_args$bg_color <- donut_bg_colors[i] |
| 176 | 78x |
if (!is.null(aes$donut_shape)) {
|
| 177 |
# Handle vectorized donut_shape |
|
| 178 | 66x |
if (length(aes$donut_shape) >= i) {
|
| 179 | 63x |
extra_args$donut_shape <- aes$donut_shape[i] |
| 180 |
} else {
|
|
| 181 | 3x |
extra_args$donut_shape <- aes$donut_shape[1] |
| 182 |
} |
|
| 183 |
} |
|
| 184 | 78x |
extra_args$show_value <- donut_show_values[i] |
| 185 | 78x |
extra_args$value_size <- donut_value_sizes[i] |
| 186 | 78x |
extra_args$value_color <- donut_value_colors[i] |
| 187 | 78x |
extra_args$value_fontface <- donut_value_fontfaces[i] |
| 188 | 78x |
extra_args$value_fontfamily <- donut_value_fontfamilies[i] |
| 189 | 78x |
if (!is.null(aes$donut_value_digits)) {
|
| 190 | 62x |
extra_args$value_digits <- aes$donut_value_digits |
| 191 |
} |
|
| 192 | 78x |
if (!is.null(aes$donut_value_prefix)) {
|
| 193 | 62x |
extra_args$value_prefix <- aes$donut_value_prefix |
| 194 |
} |
|
| 195 | 78x |
if (!is.null(aes$donut_value_suffix)) {
|
| 196 | 62x |
extra_args$value_suffix <- aes$donut_value_suffix |
| 197 |
} |
|
| 198 | 78x |
if (!is.null(aes$donut_value_format)) {
|
| 199 | 3x |
extra_args$value_format <- aes$donut_value_format |
| 200 |
} |
|
| 201 | 78x |
if (!is.null(aes$donut_border_width)) {
|
| 202 | 3x |
extra_args$donut_border_width <- aes$donut_border_width |
| 203 |
} |
|
| 204 |
} |
|
| 205 |
# Donut+Pie combined shape parameters |
|
| 206 | 1947x |
if (shapes[i] == "donut_pie") {
|
| 207 |
# Donut value (outer ring proportion) |
|
| 208 | 6x |
if (!is.null(aes$donut_values)) {
|
| 209 | 6x |
if (length(aes$donut_values) >= i) {
|
| 210 | 6x |
extra_args$donut_value <- aes$donut_values[i] |
| 211 |
} |
|
| 212 |
} |
|
| 213 |
# Pie values (inner segments) |
|
| 214 | 6x |
if (!is.null(aes$pie_values)) {
|
| 215 | 6x |
if (is.list(aes$pie_values)) {
|
| 216 | 3x |
extra_args$pie_values <- aes$pie_values[[i]] |
| 217 | 3x |
} else if (is.matrix(aes$pie_values)) {
|
| 218 | 3x |
extra_args$pie_values <- aes$pie_values[i, ] |
| 219 |
} |
|
| 220 |
} |
|
| 221 | 6x |
if (!is.null(aes$pie_colors)) {
|
| 222 | 6x |
extra_args$pie_colors <- aes$pie_colors |
| 223 |
} |
|
| 224 | 6x |
if (!is.null(aes$donut_inner_ratio)) {
|
| 225 | 3x |
extra_args$inner_ratio <- aes$donut_inner_ratio |
| 226 |
} |
|
| 227 | 6x |
if (!is.null(aes$donut_bg_color)) {
|
| 228 | 3x |
extra_args$bg_color <- aes$donut_bg_color |
| 229 |
} |
|
| 230 |
# Border width parameters |
|
| 231 | 6x |
if (!is.null(aes$pie_border_width)) {
|
| 232 | 3x |
extra_args$pie_border_width <- aes$pie_border_width |
| 233 |
} |
|
| 234 | 6x |
if (!is.null(aes$donut_border_width)) {
|
| 235 | 3x |
extra_args$donut_border_width <- aes$donut_border_width |
| 236 |
} |
|
| 237 |
} |
|
| 238 |
# Double donut + pie shape parameters |
|
| 239 | 1947x |
if (shapes[i] == "double_donut_pie") {
|
| 240 |
# Outer donut values |
|
| 241 | 33x |
if (!is.null(aes$donut_values)) {
|
| 242 | 33x |
if (is.list(aes$donut_values)) {
|
| 243 | 30x |
extra_args$donut_values <- aes$donut_values[[i]] |
| 244 | 3x |
} else if (length(aes$donut_values) >= i) {
|
| 245 | 3x |
extra_args$donut_values <- aes$donut_values[i] |
| 246 |
} |
|
| 247 |
} |
|
| 248 | 33x |
if (!is.null(aes$donut_colors)) {
|
| 249 | 6x |
if (is.list(aes$donut_colors)) {
|
| 250 | 3x |
extra_args$donut_colors <- aes$donut_colors[[i]] |
| 251 |
} else {
|
|
| 252 | 3x |
extra_args$donut_colors <- aes$donut_colors |
| 253 |
} |
|
| 254 |
} |
|
| 255 |
# Inner donut values |
|
| 256 | 33x |
if (!is.null(aes$donut2_values)) {
|
| 257 | 33x |
if (is.list(aes$donut2_values)) {
|
| 258 | 30x |
extra_args$donut2_values <- aes$donut2_values[[i]] |
| 259 | 3x |
} else if (length(aes$donut2_values) >= i) {
|
| 260 | 3x |
extra_args$donut2_values <- aes$donut2_values[i] |
| 261 |
} |
|
| 262 |
} |
|
| 263 | 33x |
if (!is.null(aes$donut2_colors)) {
|
| 264 | 9x |
if (is.list(aes$donut2_colors)) {
|
| 265 | 6x |
extra_args$donut2_colors <- aes$donut2_colors[[i]] |
| 266 |
} else {
|
|
| 267 | 3x |
extra_args$donut2_colors <- aes$donut2_colors |
| 268 |
} |
|
| 269 |
} |
|
| 270 |
# Pie values (inner segments) |
|
| 271 | 33x |
if (!is.null(aes$pie_values)) {
|
| 272 | 27x |
if (is.list(aes$pie_values)) {
|
| 273 | 24x |
extra_args$pie_values <- aes$pie_values[[i]] |
| 274 | 3x |
} else if (is.matrix(aes$pie_values)) {
|
| 275 | 3x |
extra_args$pie_values <- aes$pie_values[i, ] |
| 276 |
} |
|
| 277 |
} |
|
| 278 | 33x |
if (!is.null(aes$pie_colors)) {
|
| 279 | 27x |
extra_args$pie_colors <- aes$pie_colors |
| 280 |
} |
|
| 281 | 33x |
if (!is.null(aes$donut_inner_ratio)) {
|
| 282 | 6x |
extra_args$outer_inner_ratio <- aes$donut_inner_ratio |
| 283 |
} |
|
| 284 | 33x |
if (!is.null(aes$donut2_inner_ratio)) {
|
| 285 | 21x |
extra_args$inner_inner_ratio <- aes$donut2_inner_ratio |
| 286 |
} |
|
| 287 | 33x |
if (!is.null(aes$donut_bg_color)) {
|
| 288 | 3x |
extra_args$bg_color <- aes$donut_bg_color |
| 289 |
} |
|
| 290 |
# Border width parameters |
|
| 291 | 33x |
if (!is.null(aes$pie_border_width)) {
|
| 292 | 3x |
extra_args$pie_border_width <- aes$pie_border_width |
| 293 |
} |
|
| 294 | 33x |
if (!is.null(aes$donut_border_width)) {
|
| 295 | 3x |
extra_args$donut_border_width <- aes$donut_border_width |
| 296 |
} |
|
| 297 |
} |
|
| 298 | ||
| 299 | 1947x |
grobs[[i]] <- do.call(shape_fn, c(list( |
| 300 | 1947x |
x = nodes$x[i], |
| 301 | 1947x |
y = nodes$y[i], |
| 302 | 1947x |
size = sizes[i], |
| 303 | 1947x |
fill = fills[i], |
| 304 | 1947x |
border_color = border_colors[i], |
| 305 | 1947x |
border_width = border_widths[i], |
| 306 | 1947x |
alpha = alphas[i] |
| 307 | 1947x |
), extra_args)) |
| 308 |
} |
|
| 309 | ||
| 310 | 518x |
do.call(grid::gList, grobs) |
| 311 |
} |
|
| 312 | ||
| 313 |
#' Render Node Labels |
|
| 314 |
#' |
|
| 315 |
#' Create grid grobs for node labels. |
|
| 316 |
#' |
|
| 317 |
#' @param network A CographNetwork object. |
|
| 318 |
#' @return A grid gList of label grobs. |
|
| 319 |
#' @keywords internal |
|
| 320 |
render_node_labels_grid <- function(network) {
|
|
| 321 | 505x |
nodes <- network$get_nodes() |
| 322 | 505x |
aes <- network$get_node_aes() |
| 323 | 505x |
theme <- network$get_theme() |
| 324 | 505x |
n <- nrow(nodes) |
| 325 | ||
| 326 | 1x |
if (n == 0) return(grid::gList()) |
| 327 | ||
| 328 |
# Check if labels should be shown |
|
| 329 | 504x |
show_labels <- if (!is.null(aes$show_labels)) aes$show_labels else TRUE |
| 330 | 2x |
if (!show_labels) return(grid::gList()) |
| 331 | ||
| 332 |
# Resolve aesthetics |
|
| 333 | 502x |
labels <- if (!is.null(nodes$label)) nodes$label else as.character(seq_len(n)) |
| 334 | 502x |
sizes <- expand_param( |
| 335 | 502x |
if (!is.null(aes$size)) aes$size else 0.05, |
| 336 | 502x |
n, "node_size" |
| 337 |
) |
|
| 338 | 502x |
label_sizes <- expand_param( |
| 339 | 502x |
if (!is.null(aes$label_size)) aes$label_size else theme$get("label_size"),
|
| 340 | 502x |
n, "label_size" |
| 341 |
) |
|
| 342 | 502x |
label_colors <- expand_param( |
| 343 | 502x |
if (!is.null(aes$label_color)) aes$label_color else theme$get("label_color"),
|
| 344 | 502x |
n, "label_color" |
| 345 |
) |
|
| 346 | 502x |
positions <- expand_param( |
| 347 | 502x |
if (!is.null(aes$label_position)) aes$label_position else "center", |
| 348 | 502x |
n, "label_position" |
| 349 |
) |
|
| 350 | ||
| 351 |
# Label font properties (strict vectorization) |
|
| 352 | 502x |
label_fontfaces <- expand_param( |
| 353 | 502x |
if (!is.null(aes$label_fontface)) aes$label_fontface else "plain", |
| 354 | 502x |
n, "label_fontface" |
| 355 |
) |
|
| 356 | 502x |
label_fontfamilies <- expand_param( |
| 357 | 502x |
if (!is.null(aes$label_fontfamily)) aes$label_fontfamily else "sans", |
| 358 | 502x |
n, "label_fontfamily" |
| 359 |
) |
|
| 360 | 502x |
label_hjusts <- expand_param( |
| 361 | 502x |
if (!is.null(aes$label_hjust)) aes$label_hjust else 0.5, |
| 362 | 502x |
n, "label_hjust" |
| 363 |
) |
|
| 364 | 502x |
label_vjusts <- expand_param( |
| 365 | 502x |
if (!is.null(aes$label_vjust)) aes$label_vjust else 0.5, |
| 366 | 502x |
n, "label_vjust" |
| 367 |
) |
|
| 368 | 502x |
label_angles <- expand_param( |
| 369 | 502x |
if (!is.null(aes$label_angle)) aes$label_angle else 0, |
| 370 | 502x |
n, "label_angle" |
| 371 |
) |
|
| 372 | ||
| 373 |
# Create label grobs |
|
| 374 | 502x |
grobs <- vector("list", n)
|
| 375 | 502x |
for (i in seq_len(n)) {
|
| 376 |
# Calculate label position |
|
| 377 | 1896x |
x <- nodes$x[i] |
| 378 | 1896x |
y <- nodes$y[i] |
| 379 | ||
| 380 | 1896x |
offset <- sizes[i] + 0.02 |
| 381 | ||
| 382 | 1896x |
switch(positions[i], |
| 383 | 15x |
above = { y <- y + offset },
|
| 384 | 4x |
below = { y <- y - offset },
|
| 385 | 4x |
left = { x <- x - offset },
|
| 386 | 4x |
right = { x <- x + offset }
|
| 387 |
) |
|
| 388 | ||
| 389 |
# Convert fontface string to numeric |
|
| 390 | 1896x |
fontface_num <- switch(label_fontfaces[i], |
| 391 | 1896x |
"plain" = 1, |
| 392 | 1896x |
"bold" = 2, |
| 393 | 1896x |
"italic" = 3, |
| 394 | 1896x |
"bold.italic" = 4, |
| 395 | 1896x |
1 |
| 396 |
) |
|
| 397 | ||
| 398 | 1896x |
grobs[[i]] <- grid::textGrob( |
| 399 | 1896x |
label = labels[i], |
| 400 | 1896x |
x = grid::unit(x, "npc"), |
| 401 | 1896x |
y = grid::unit(y, "npc"), |
| 402 | 1896x |
hjust = label_hjusts[i], |
| 403 | 1896x |
vjust = label_vjusts[i], |
| 404 | 1896x |
rot = label_angles[i], |
| 405 | 1896x |
gp = grid::gpar( |
| 406 | 1896x |
fontsize = label_sizes[i], |
| 407 | 1896x |
col = label_colors[i], |
| 408 | 1896x |
fontface = fontface_num, |
| 409 | 1896x |
fontfamily = label_fontfamilies[i] |
| 410 |
) |
|
| 411 |
) |
|
| 412 |
} |
|
| 413 | ||
| 414 | 502x |
do.call(grid::gList, grobs) |
| 415 |
} |
| 1 |
#' @title Base R Arrow Drawing |
|
| 2 |
#' @description Arrow head drawing functions for splot() edges. |
|
| 3 |
#' @name splot-arrows |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Calculate Arrow Base Midpoint |
|
| 8 |
#' |
|
| 9 |
#' Returns the midpoint between the arrow wings (where the curve should end). |
|
| 10 |
#' This is used to connect the edge line to the back of the arrow head. |
|
| 11 |
#' |
|
| 12 |
#' @param x Arrow tip x coordinate. |
|
| 13 |
#' @param y Arrow tip y coordinate. |
|
| 14 |
#' @param angle Angle of incoming edge (radians). |
|
| 15 |
#' @param size Arrow size in user coordinates. |
|
| 16 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 17 |
#' @return List with x, y coordinates of the arrow base midpoint. |
|
| 18 |
#' @keywords internal |
|
| 19 |
arrow_base_midpoint <- function(x, y, angle, size, arrow_angle = pi/6) {
|
|
| 20 | 1411x |
left_angle <- angle + pi - arrow_angle |
| 21 | 1411x |
right_angle <- angle + pi + arrow_angle |
| 22 | 1411x |
back_len <- size / cos(arrow_angle) |
| 23 | ||
| 24 | 1411x |
left_x <- x + back_len * cos(left_angle) |
| 25 | 1411x |
left_y <- y + back_len * sin(left_angle) |
| 26 | 1411x |
right_x <- x + back_len * cos(right_angle) |
| 27 | 1411x |
right_y <- y + back_len * sin(right_angle) |
| 28 | ||
| 29 | 1411x |
list(x = (left_x + right_x) / 2, y = (left_y + right_y) / 2) |
| 30 |
} |
|
| 31 | ||
| 32 |
#' Calculate Arrow Radius |
|
| 33 |
#' |
|
| 34 |
#' Returns the distance from arrow tip to base midpoint. |
|
| 35 |
#' This is how far back from the tip the arrow extends. |
|
| 36 |
#' |
|
| 37 |
#' @param size Arrow size in user coordinates. |
|
| 38 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 39 |
#' @return The arrow radius (distance from tip to base). |
|
| 40 |
#' @keywords internal |
|
| 41 |
arrow_radius <- function(size, arrow_angle = pi/6) {
|
|
| 42 | 5x |
size # The arrow extends 'size' units back from tip |
| 43 |
} |
|
| 44 | ||
| 45 |
#' Draw Arrow Head |
|
| 46 |
#' |
|
| 47 |
#' Draws a filled triangular arrow head at the specified position. |
|
| 48 |
#' |
|
| 49 |
#' @param x Arrow tip x coordinate. |
|
| 50 |
#' @param y Arrow tip y coordinate. |
|
| 51 |
#' @param angle Angle of incoming edge (radians). |
|
| 52 |
#' @param size Arrow size in user coordinates. |
|
| 53 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 54 |
#' @param col Arrow fill color. |
|
| 55 |
#' @param border Arrow border color (default same as fill). |
|
| 56 |
#' @param lwd Border line width. |
|
| 57 |
#' @keywords internal |
|
| 58 |
draw_arrow_base <- function(x, y, angle, size, arrow_angle = pi/6, col = "black", |
|
| 59 |
border = NULL, lwd = 1) {
|
|
| 60 | 1462x |
if (is.null(border)) border <- col |
| 61 | ||
| 62 |
# Arrow points relative to tip |
|
| 63 | 1464x |
left_angle <- angle + pi - arrow_angle |
| 64 | 1464x |
right_angle <- angle + pi + arrow_angle |
| 65 | 1464x |
back_len <- size / cos(arrow_angle) |
| 66 | ||
| 67 | 1464x |
left_x <- x + back_len * cos(left_angle) |
| 68 | 1464x |
left_y <- y + back_len * sin(left_angle) |
| 69 | 1464x |
right_x <- x + back_len * cos(right_angle) |
| 70 | 1464x |
right_y <- y + back_len * sin(right_angle) |
| 71 | ||
| 72 |
# Draw filled polygon |
|
| 73 | 1464x |
graphics::polygon( |
| 74 | 1464x |
x = c(x, left_x, right_x), |
| 75 | 1464x |
y = c(y, left_y, right_y), |
| 76 | 1464x |
col = col, |
| 77 | 1464x |
border = border, |
| 78 | 1464x |
lwd = lwd |
| 79 |
) |
|
| 80 |
} |
|
| 81 | ||
| 82 |
#' Calculate Arrow Head Points |
|
| 83 |
#' |
|
| 84 |
#' Returns the vertices for an arrow head polygon without drawing. |
|
| 85 |
#' |
|
| 86 |
#' @param x Arrow tip x coordinate. |
|
| 87 |
#' @param y Arrow tip y coordinate. |
|
| 88 |
#' @param angle Angle of incoming edge (radians). |
|
| 89 |
#' @param size Arrow size. |
|
| 90 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 91 |
#' @return List with x, y vectors and midpoint coordinates. |
|
| 92 |
#' @keywords internal |
|
| 93 |
arrow_head_points <- function(x, y, angle, size, arrow_angle = pi/6) {
|
|
| 94 |
# Arrow points relative to tip |
|
| 95 | 4x |
left_angle <- angle + pi - arrow_angle |
| 96 | 4x |
right_angle <- angle + pi + arrow_angle |
| 97 | 4x |
back_len <- size / cos(arrow_angle) |
| 98 | ||
| 99 | 4x |
left_x <- x + back_len * cos(left_angle) |
| 100 | 4x |
left_y <- y + back_len * sin(left_angle) |
| 101 | 4x |
right_x <- x + back_len * cos(right_angle) |
| 102 | 4x |
right_y <- y + back_len * sin(right_angle) |
| 103 | ||
| 104 |
# Midpoint of arrow base (where line should connect) |
|
| 105 | 4x |
mid_x <- (left_x + right_x) / 2 |
| 106 | 4x |
mid_y <- (left_y + right_y) / 2 |
| 107 | ||
| 108 | 4x |
list( |
| 109 | 4x |
x = c(x, left_x, right_x), |
| 110 | 4x |
y = c(y, left_y, right_y), |
| 111 | 4x |
mid_x = mid_x, |
| 112 | 4x |
mid_y = mid_y, |
| 113 | 4x |
back_len = back_len |
| 114 |
) |
|
| 115 |
} |
|
| 116 | ||
| 117 |
#' Draw Curved Arrow Head |
|
| 118 |
#' |
|
| 119 |
#' Draws an arrow head at the end of a curved edge, with angle following |
|
| 120 |
#' the curve direction. |
|
| 121 |
#' |
|
| 122 |
#' @param spline_x X coordinates of the spline. |
|
| 123 |
#' @param spline_y Y coordinates of the spline. |
|
| 124 |
#' @param size Arrow size. |
|
| 125 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 126 |
#' @param col Arrow fill color. |
|
| 127 |
#' @param border Arrow border color. |
|
| 128 |
#' @keywords internal |
|
| 129 |
draw_curved_arrow_base <- function(spline_x, spline_y, size, arrow_angle = pi/6, |
|
| 130 |
col = "black", border = NULL) {
|
|
| 131 | 4x |
n <- length(spline_x) |
| 132 | 1x |
if (n < 2) return(invisible()) |
| 133 | ||
| 134 |
# Get angle from last two points of spline |
|
| 135 | 3x |
angle <- splot_angle( |
| 136 | 3x |
spline_x[n - 1], spline_y[n - 1], |
| 137 | 3x |
spline_x[n], spline_y[n] |
| 138 |
) |
|
| 139 | ||
| 140 |
# Draw arrow at endpoint |
|
| 141 | 3x |
draw_arrow_base( |
| 142 | 3x |
x = spline_x[n], |
| 143 | 3x |
y = spline_y[n], |
| 144 | 3x |
angle = angle, |
| 145 | 3x |
size = size, |
| 146 | 3x |
arrow_angle = arrow_angle, |
| 147 | 3x |
col = col, |
| 148 | 3x |
border = border |
| 149 |
) |
|
| 150 |
} |
|
| 151 | ||
| 152 |
#' Draw Open Arrow Head |
|
| 153 |
#' |
|
| 154 |
#' Draws an open (unfilled) V-shaped arrow head. |
|
| 155 |
#' |
|
| 156 |
#' @param x Arrow tip x coordinate. |
|
| 157 |
#' @param y Arrow tip y coordinate. |
|
| 158 |
#' @param angle Angle of incoming edge (radians). |
|
| 159 |
#' @param size Arrow size. |
|
| 160 |
#' @param arrow_angle Arrow head angle in radians. Default pi/6 (30 degrees). |
|
| 161 |
#' @param col Arrow color. |
|
| 162 |
#' @param lwd Line width. |
|
| 163 |
#' @keywords internal |
|
| 164 |
draw_open_arrow_base <- function(x, y, angle, size, arrow_angle = pi/6, |
|
| 165 |
col = "black", lwd = 1) {
|
|
| 166 |
# Arrow points |
|
| 167 | 3x |
left_angle <- angle + pi - arrow_angle |
| 168 | 3x |
right_angle <- angle + pi + arrow_angle |
| 169 | 3x |
back_len <- size / cos(arrow_angle) |
| 170 | ||
| 171 | 3x |
left_x <- x + back_len * cos(left_angle) |
| 172 | 3x |
left_y <- y + back_len * sin(left_angle) |
| 173 | 3x |
right_x <- x + back_len * cos(right_angle) |
| 174 | 3x |
right_y <- y + back_len * sin(right_angle) |
| 175 | ||
| 176 |
# Draw lines only (no fill) |
|
| 177 | 3x |
graphics::lines( |
| 178 | 3x |
x = c(left_x, x, right_x), |
| 179 | 3x |
y = c(left_y, y, right_y), |
| 180 | 3x |
col = col, |
| 181 | 3x |
lwd = lwd |
| 182 |
) |
|
| 183 |
} |
|
| 184 | ||
| 185 |
#' Draw Circle Arrow (Dot) |
|
| 186 |
#' |
|
| 187 |
#' Draws a circular dot at the arrow position (alternative to triangular arrow). |
|
| 188 |
#' |
|
| 189 |
#' @param x Position x coordinate. |
|
| 190 |
#' @param y Position y coordinate. |
|
| 191 |
#' @param size Dot radius. |
|
| 192 |
#' @param col Fill color. |
|
| 193 |
#' @param border Border color. |
|
| 194 |
#' @keywords internal |
|
| 195 |
draw_circle_arrow_base <- function(x, y, size, col = "black", border = NULL) {
|
|
| 196 | 2x |
if (is.null(border)) border <- col |
| 197 | ||
| 198 |
# Use symbols() for perfect circles |
|
| 199 | 3x |
graphics::symbols( |
| 200 | 3x |
x = x, |
| 201 | 3x |
y = y, |
| 202 | 3x |
circles = size, |
| 203 | 3x |
inches = FALSE, |
| 204 | 3x |
add = TRUE, |
| 205 | 3x |
fg = border, |
| 206 | 3x |
bg = col |
| 207 |
) |
|
| 208 |
} |
|
| 209 | ||
| 210 |
#' Calculate Shortened Edge Endpoint |
|
| 211 |
#' |
|
| 212 |
#' Calculates where to stop drawing an edge line so the arrow head |
|
| 213 |
#' doesn't overlap with the line. |
|
| 214 |
#' |
|
| 215 |
#' @param x1,y1 Start point. |
|
| 216 |
#' @param x2,y2 End point (arrow tip). |
|
| 217 |
#' @param arrow_size Arrow size. |
|
| 218 |
#' @return List with x, y coordinates of shortened endpoint. |
|
| 219 |
#' @keywords internal |
|
| 220 |
shorten_edge_for_arrow <- function(x1, y1, x2, y2, arrow_size) {
|
|
| 221 | 5x |
angle <- splot_angle(x1, y1, x2, y2) |
| 222 | ||
| 223 |
# Move endpoint back by arrow length |
|
| 224 | 5x |
list( |
| 225 | 5x |
x = x2 - arrow_size * cos(angle), |
| 226 | 5x |
y = y2 - arrow_size * sin(angle) |
| 227 |
) |
|
| 228 |
} |
| 1 |
#' Multilevel Network Visualization |
|
| 2 |
#' |
|
| 3 |
#' Visualizes multilevel/multiplex networks where multiple layers are stacked |
|
| 4 |
#' in a 3D perspective view. Each layer contains nodes connected by solid edges |
|
| 5 |
#' (within-layer), while dashed lines connect nodes between adjacent layers |
|
| 6 |
#' (inter-layer edges). Each layer is enclosed in a parallelogram shell giving |
|
| 7 |
#' a pseudo-3D appearance. |
|
| 8 |
#' |
|
| 9 |
#' \if{html}{\figure{mlna_example.png}{options: width=600 alt="Multilevel network example"}}
|
|
| 10 |
#' \if{latex}{\figure{mlna_example.png}{options: width=4in}}
|
|
| 11 |
#' |
|
| 12 |
#' @param model A tna object or weight matrix. |
|
| 13 |
#' @param layer_list List of character vectors defining layers. Each element |
|
| 14 |
#' contains node names belonging to that layer. Layers are displayed from |
|
| 15 |
#' top to bottom in list order. |
|
| 16 |
#' @param layout Node layout within layers: "horizontal" (default) spreads nodes |
|
| 17 |
#' horizontally, "circle" arranges nodes in an ellipse, "spring" uses |
|
| 18 |
#' force-directed placement based on within-layer connections. |
|
| 19 |
#' @param layer_spacing Vertical distance between layer centers. Default 2.2. |
|
| 20 |
#' @param layer_width Horizontal width of each layer shell. Default 4.5. |
|
| 21 |
#' @param layer_depth Depth of each layer (for 3D effect). Default 2.2. |
|
| 22 |
#' @param skew_angle Angle of perspective skew in degrees. Default 25. |
|
| 23 |
#' @param node_spacing Node placement ratio within layer (0-1). Default 0.7. |
|
| 24 |
#' Higher values spread nodes closer to the layer edges. |
|
| 25 |
#' @param colors Vector of colors for each layer. Default auto-generated. |
|
| 26 |
#' @param shapes Vector of shapes for each layer. Default cycles through |
|
| 27 |
#' "circle", "square", "diamond", "triangle". |
|
| 28 |
#' @param edge_colors Vector of edge colors by source layer. If NULL (default), |
|
| 29 |
#' uses darker versions of layer colors. |
|
| 30 |
#' @param within_edges Logical. Show edges within layers (solid lines). Default TRUE. |
|
| 31 |
#' @param between_edges Logical. Show edges between adjacent layers (dashed lines). |
|
| 32 |
#' Default TRUE. |
|
| 33 |
#' @param between_style Line style for between-layer edges. Default 2 (dashed). |
|
| 34 |
#' Use 1 for solid, 3 for dotted. |
|
| 35 |
#' @param show_border Logical. Draw parallelogram shells around layers. Default TRUE. |
|
| 36 |
#' @param legend Logical. Whether to show legend. Default TRUE. |
|
| 37 |
#' @param legend_position Position for legend. Default "topright". |
|
| 38 |
#' @param curvature Edge curvature for within-layer edges. Default 0.15. |
|
| 39 |
#' @param node_size Size of nodes. Default 2.5. |
|
| 40 |
#' @param minimum Minimum edge weight threshold. Edges below this are hidden. |
|
| 41 |
#' Default 0. |
|
| 42 |
#' @param ... Additional parameters (currently unused). |
|
| 43 |
#' |
|
| 44 |
#' @return Invisibly returns NULL. |
|
| 45 |
#' |
|
| 46 |
#' @export |
|
| 47 |
#' |
|
| 48 |
#' @examples |
|
| 49 |
#' \dontrun{
|
|
| 50 |
#' # Create multilevel network |
|
| 51 |
#' set.seed(42) |
|
| 52 |
#' nodes <- paste0("N", 1:15)
|
|
| 53 |
#' m <- matrix(runif(225, 0, 0.3), 15, 15) |
|
| 54 |
#' diag(m) <- 0 |
|
| 55 |
#' colnames(m) <- rownames(m) <- nodes |
|
| 56 |
#' |
|
| 57 |
#' # Define 3 layers |
|
| 58 |
#' layers <- list( |
|
| 59 |
#' Macro = paste0("N", 1:5),
|
|
| 60 |
#' Meso = paste0("N", 6:10),
|
|
| 61 |
#' Micro = paste0("N", 11:15)
|
|
| 62 |
#' ) |
|
| 63 |
#' |
|
| 64 |
#' # Basic usage |
|
| 65 |
#' plot_mlna(m, layers) |
|
| 66 |
#' |
|
| 67 |
#' # Customized |
|
| 68 |
#' plot_mlna(m, layers, |
|
| 69 |
#' layer_spacing = 2.5, |
|
| 70 |
#' layer_width = 5, |
|
| 71 |
#' between_style = 2, # dashed |
|
| 72 |
#' minimum = 0.1) |
|
| 73 |
#' |
|
| 74 |
#' # Circle layout within layers |
|
| 75 |
#' plot_mlna(m, layers, layout = "circle") |
|
| 76 |
#' } |
|
| 77 |
plot_mlna <- function( |
|
| 78 |
model, |
|
| 79 |
layer_list, |
|
| 80 |
layout = "horizontal", |
|
| 81 |
layer_spacing = 2.2, |
|
| 82 |
layer_width = 4.5, |
|
| 83 |
layer_depth = 2.2, |
|
| 84 |
skew_angle = 25, |
|
| 85 |
node_spacing = 0.7, |
|
| 86 |
colors = NULL, |
|
| 87 |
shapes = NULL, |
|
| 88 |
edge_colors = NULL, |
|
| 89 |
within_edges = TRUE, |
|
| 90 |
between_edges = TRUE, |
|
| 91 |
between_style = 2, |
|
| 92 |
show_border = TRUE, |
|
| 93 |
legend = TRUE, |
|
| 94 |
legend_position = "topright", |
|
| 95 |
curvature = 0.15, |
|
| 96 |
node_size = 3, |
|
| 97 |
minimum = 0, |
|
| 98 |
scale = 1, |
|
| 99 |
... |
|
| 100 |
) {
|
|
| 101 |
# Apply scale for high-resolution output |
|
| 102 | 48x |
size_scale <- sqrt(scale) |
| 103 | 48x |
node_size <- node_size / size_scale |
| 104 | 48x |
edge_scale <- 1 / size_scale |
| 105 | ||
| 106 |
# ========================================================================== |
|
| 107 |
# 1. Input Validation & Setup |
|
| 108 |
# ========================================================================== |
|
| 109 | ||
| 110 |
# Validate layer_list |
|
| 111 | 48x |
n_layers <- length(layer_list) |
| 112 | 48x |
if (!is.list(layer_list) || n_layers < 2) {
|
| 113 | 2x |
stop("layer_list must be a list of 2+ character vectors", call. = FALSE)
|
| 114 |
} |
|
| 115 | ||
| 116 |
# Get labels and weights from model |
|
| 117 | 46x |
if (inherits(model, "tna")) {
|
| 118 | 1x |
lab <- model$labels |
| 119 | 1x |
weights <- model$weights |
| 120 | 45x |
} else if (is.matrix(model)) {
|
| 121 | 44x |
lab <- colnames(model) |
| 122 | 1x |
if (is.null(lab)) lab <- as.character(seq_len(ncol(model))) |
| 123 | 44x |
weights <- model |
| 124 |
} else {
|
|
| 125 | 1x |
stop("model must be a tna object or matrix", call. = FALSE)
|
| 126 |
} |
|
| 127 | ||
| 128 | 45x |
n <- length(lab) |
| 129 | ||
| 130 |
# Check no overlap between layers |
|
| 131 | 45x |
all_nodes <- unlist(layer_list) |
| 132 | 45x |
if (anyDuplicated(all_nodes)) {
|
| 133 | 1x |
dups <- all_nodes[duplicated(all_nodes)] |
| 134 | 1x |
stop("layer_list groups must not overlap. Duplicates: ",
|
| 135 | 1x |
paste(unique(dups), collapse = ", "), call. = FALSE) |
| 136 |
} |
|
| 137 | ||
| 138 |
# Get indices for each layer and validate |
|
| 139 | 44x |
layer_indices <- lapply(layer_list, function(nodes) {
|
| 140 | 88x |
idx <- match(nodes, lab) |
| 141 | 88x |
if (any(is.na(idx))) {
|
| 142 | 1x |
missing <- nodes[is.na(idx)] |
| 143 | 1x |
stop("Nodes not found in model: ", paste(missing, collapse = ", "), call. = FALSE)
|
| 144 |
} |
|
| 145 | 87x |
idx |
| 146 |
}) |
|
| 147 | ||
| 148 |
# Node-to-layer mapping |
|
| 149 | 43x |
node_to_layer <- rep(NA, n) |
| 150 | 43x |
for (i in seq_len(n_layers)) {
|
| 151 | 87x |
node_to_layer[layer_indices[[i]]] <- i |
| 152 |
} |
|
| 153 | ||
| 154 |
# ========================================================================== |
|
| 155 |
# 2. Color & Shape Palettes |
|
| 156 |
# ========================================================================== |
|
| 157 | ||
| 158 | 43x |
color_palette <- c("#ffd89d", "#a68ba5", "#7eb5d6", "#98d4a2",
|
| 159 | 43x |
"#f4a582", "#92c5de", "#d6c1de", "#b8e186", |
| 160 | 43x |
"#fdcdac", "#cbd5e8", "#f4cae4", "#e6f5c9") |
| 161 | ||
| 162 | 43x |
shape_palette <- c("circle", "square", "diamond", "triangle",
|
| 163 | 43x |
"pentagon", "hexagon", "star", "cross") |
| 164 | ||
| 165 | 43x |
edge_color_palette <- c("#e6a500", "#7a5a7a", "#4a90b8", "#5cb85c",
|
| 166 | 43x |
"#d9534f", "#5bc0de", "#9b59b6", "#8bc34a", |
| 167 | 43x |
"#ff7043", "#78909c", "#ab47bc", "#aed581") |
| 168 | ||
| 169 | 43x |
layer_colors <- if (is.null(colors)) rep_len(color_palette, n_layers) else colors |
| 170 | 43x |
layer_shapes <- if (is.null(shapes)) rep_len(shape_palette, n_layers) else shapes |
| 171 | ||
| 172 | 43x |
if (is.null(edge_colors)) {
|
| 173 | 42x |
edge_colors <- rep_len(edge_color_palette, n_layers) |
| 174 |
} |
|
| 175 | ||
| 176 |
# ========================================================================== |
|
| 177 |
# 3. Compute 3D Perspective Layer Positions |
|
| 178 |
# ========================================================================== |
|
| 179 | ||
| 180 |
# Convert skew angle to radians |
|
| 181 | 43x |
skew_rad <- skew_angle * pi / 180 |
| 182 | ||
| 183 |
# Layer base y-positions (top to bottom) |
|
| 184 | 43x |
layer_base_y <- seq(0, -(n_layers - 1) * layer_spacing, length.out = n_layers) |
| 185 | ||
| 186 |
# Node positions in 3D perspective |
|
| 187 | 43x |
x_pos <- rep(0, n) |
| 188 | 43x |
y_pos <- rep(0, n) |
| 189 | ||
| 190 |
# Store layer plane info for drawing |
|
| 191 | 43x |
layer_planes <- vector("list", n_layers)
|
| 192 | ||
| 193 | 43x |
for (i in seq_len(n_layers)) {
|
| 194 | 87x |
idx <- layer_indices[[i]] |
| 195 | 87x |
n_nodes <- length(idx) |
| 196 | 87x |
base_y <- layer_base_y[i] |
| 197 | ||
| 198 |
# Skew offset for this layer (layers higher up are shifted right) |
|
| 199 | 87x |
skew_offset <- (n_layers - i) * layer_depth * tan(skew_rad) * 0.5 |
| 200 | ||
| 201 | 87x |
if (layout == "horizontal") {
|
| 202 |
# Spread nodes horizontally within layer |
|
| 203 | 77x |
if (n_nodes > 1) {
|
| 204 | 71x |
local_x <- seq(-layer_width / 2 * node_spacing, |
| 205 | 71x |
layer_width / 2 * node_spacing, |
| 206 | 71x |
length.out = n_nodes) |
| 207 |
} else {
|
|
| 208 | 6x |
local_x <- 0 |
| 209 |
} |
|
| 210 | 77x |
local_y <- rep(0, n_nodes) |
| 211 | 10x |
} else if (layout == "circle") {
|
| 212 |
# Arrange in ellipse within layer (squashed for perspective) |
|
| 213 | 4x |
angles <- pi / 2 - (seq_len(n_nodes) - 1) * 2 * pi / n_nodes |
| 214 | 4x |
radius_x <- layer_width / 3 * node_spacing |
| 215 | 4x |
radius_y <- layer_depth / 3 * node_spacing |
| 216 | 4x |
local_x <- radius_x * cos(angles) |
| 217 | 4x |
local_y <- radius_y * sin(angles) |
| 218 | 6x |
} else if (layout == "spring") {
|
| 219 |
# Force-directed spring layout within layer |
|
| 220 | 6x |
if (n_nodes > 1) {
|
| 221 |
# Extract within-layer weights |
|
| 222 | 5x |
layer_weights <- weights[idx, idx, drop = FALSE] |
| 223 | ||
| 224 |
# Initialize positions randomly |
|
| 225 | 5x |
set.seed(i * 100) # Reproducible per layer |
| 226 | 5x |
local_x <- runif(n_nodes, -1, 1) |
| 227 | 5x |
local_y <- runif(n_nodes, -1, 1) |
| 228 | ||
| 229 |
# Simple force-directed iterations |
|
| 230 | 5x |
k <- 1.0 # optimal distance |
| 231 | 5x |
iterations <- 100 |
| 232 | ||
| 233 | 5x |
for (iter in seq_len(iterations)) {
|
| 234 |
# Calculate repulsive forces (all pairs) |
|
| 235 | 500x |
fx <- rep(0, n_nodes) |
| 236 | 500x |
fy <- rep(0, n_nodes) |
| 237 | ||
| 238 | 500x |
for (j in seq_len(n_nodes)) {
|
| 239 | 1900x |
for (m in seq_len(n_nodes)) {
|
| 240 | 7700x |
if (j != m) {
|
| 241 | 5800x |
dx <- local_x[j] - local_x[m] |
| 242 | 5800x |
dy <- local_y[j] - local_y[m] |
| 243 | 5800x |
dist <- sqrt(dx^2 + dy^2) + 0.01 |
| 244 |
# Repulsive force |
|
| 245 | 5800x |
force <- k^2 / dist |
| 246 | 5800x |
fx[j] <- fx[j] + (dx / dist) * force |
| 247 | 5800x |
fy[j] <- fy[j] + (dy / dist) * force |
| 248 |
} |
|
| 249 |
} |
|
| 250 |
} |
|
| 251 | ||
| 252 |
# Calculate attractive forces (connected pairs) |
|
| 253 | 500x |
for (j in seq_len(n_nodes)) {
|
| 254 | 1900x |
for (m in seq_len(n_nodes)) {
|
| 255 | 7700x |
if (j != m) {
|
| 256 | 5800x |
w <- layer_weights[j, m] + layer_weights[m, j] |
| 257 | 5800x |
if (!is.na(w) && w > 0) {
|
| 258 | 5200x |
dx <- local_x[j] - local_x[m] |
| 259 | 5200x |
dy <- local_y[j] - local_y[m] |
| 260 | 5200x |
dist <- sqrt(dx^2 + dy^2) + 0.01 |
| 261 |
# Attractive force |
|
| 262 | 5200x |
force <- dist^2 / k * w * 2 |
| 263 | 5200x |
fx[j] <- fx[j] - (dx / dist) * force |
| 264 | 5200x |
fy[j] <- fy[j] - (dy / dist) * force |
| 265 |
} |
|
| 266 |
} |
|
| 267 |
} |
|
| 268 |
} |
|
| 269 | ||
| 270 |
# Apply forces with cooling |
|
| 271 | 500x |
temp <- 0.5 * (1 - iter / iterations) |
| 272 | 500x |
local_x <- local_x + pmax(pmin(fx * temp, 0.5), -0.5) |
| 273 | 500x |
local_y <- local_y + pmax(pmin(fy * temp, 0.5), -0.5) |
| 274 |
} |
|
| 275 | ||
| 276 |
# Scale to fit layer |
|
| 277 | 5x |
x_range <- range(local_x) |
| 278 | 5x |
y_range <- range(local_y) |
| 279 | 5x |
if (diff(x_range) > 0) {
|
| 280 | 5x |
local_x <- (local_x - mean(x_range)) / diff(x_range) * layer_width * node_spacing * 0.8 |
| 281 |
} |
|
| 282 | 5x |
if (diff(y_range) > 0) {
|
| 283 | 5x |
local_y <- (local_y - mean(y_range)) / diff(y_range) * layer_depth * node_spacing * 0.6 |
| 284 |
} |
|
| 285 |
} else {
|
|
| 286 | 1x |
local_x <- 0 |
| 287 | 1x |
local_y <- 0 |
| 288 |
} |
|
| 289 |
} |
|
| 290 | ||
| 291 |
# Apply perspective transformation |
|
| 292 |
# x stays mostly the same, y gets shifted based on depth |
|
| 293 | 87x |
x_pos[idx] <- local_x + skew_offset |
| 294 | 87x |
y_pos[idx] <- base_y + local_y * cos(skew_rad) |
| 295 | ||
| 296 |
# Store layer plane corners for drawing the parallelogram |
|
| 297 |
# Four corners: front-left, front-right, back-right, back-left |
|
| 298 | 87x |
hw <- layer_width / 2 |
| 299 | 87x |
hd <- layer_depth / 2 |
| 300 | 87x |
layer_planes[[i]] <- list( |
| 301 | 87x |
corners = matrix(c( |
| 302 | 87x |
-hw + skew_offset - hd * tan(skew_rad), base_y - hd * cos(skew_rad), # back-left |
| 303 | 87x |
hw + skew_offset - hd * tan(skew_rad), base_y - hd * cos(skew_rad), # back-right |
| 304 | 87x |
hw + skew_offset + hd * tan(skew_rad), base_y + hd * cos(skew_rad), # front-right |
| 305 | 87x |
-hw + skew_offset + hd * tan(skew_rad), base_y + hd * cos(skew_rad) # front-left |
| 306 | 87x |
), ncol = 2, byrow = TRUE), |
| 307 | 87x |
center_y = base_y, |
| 308 | 87x |
skew_offset = skew_offset |
| 309 |
) |
|
| 310 |
} |
|
| 311 | ||
| 312 |
# ========================================================================== |
|
| 313 |
# 4. Set Up Plot |
|
| 314 |
# ========================================================================== |
|
| 315 | ||
| 316 |
# Calculate plot dimensions with padding |
|
| 317 | 43x |
all_x <- c(x_pos, unlist(lapply(layer_planes, function(p) p$corners[, 1]))) |
| 318 | 43x |
all_y <- c(y_pos, unlist(lapply(layer_planes, function(p) p$corners[, 2]))) |
| 319 | 43x |
x_range <- range(all_x) + c(-0.5, 1.5) |
| 320 | 43x |
y_range <- range(all_y) + c(-0.5, 0.8) |
| 321 | ||
| 322 |
# Set up blank plot |
|
| 323 | 43x |
graphics::plot.new() |
| 324 | 43x |
graphics::plot.window(xlim = x_range, ylim = y_range, asp = 1) |
| 325 | ||
| 326 |
# Get max weight for scaling |
|
| 327 | 43x |
max_w <- max(abs(weights), na.rm = TRUE) |
| 328 | 1x |
if (is.na(max_w) || max_w == 0) max_w <- 1 |
| 329 | ||
| 330 |
# ========================================================================== |
|
| 331 |
# 5. Draw from back to front (painter's algorithm) |
|
| 332 |
# ========================================================================== |
|
| 333 | ||
| 334 |
# Draw layers from bottom (back) to top (front) |
|
| 335 | 43x |
for (i in rev(seq_len(n_layers))) {
|
| 336 | 87x |
idx <- layer_indices[[i]] |
| 337 | 87x |
plane <- layer_planes[[i]] |
| 338 | 87x |
corners <- plane$corners |
| 339 | ||
| 340 |
# --- Draw between-layer edges TO this layer (from layer below) --- |
|
| 341 | 87x |
if (isTRUE(between_edges) && i < n_layers) {
|
| 342 | 43x |
next_layer <- i + 1 |
| 343 | 43x |
next_idx <- layer_indices[[next_layer]] |
| 344 | ||
| 345 |
# Edges from next layer (below) to this layer |
|
| 346 | 43x |
for (src_idx in next_idx) {
|
| 347 | 127x |
for (tgt_idx in idx) {
|
| 348 | 381x |
weight <- weights[src_idx, tgt_idx] |
| 349 | 381x |
if (!is.na(weight) && weight > minimum) {
|
| 350 | 212x |
lwd <- (0.3 + 1.2 * (abs(weight) / max_w)) * edge_scale |
| 351 | 212x |
edge_col <- grDevices::adjustcolor(edge_colors[next_layer], alpha.f = 0.6) |
| 352 | 212x |
graphics::segments( |
| 353 | 212x |
x0 = x_pos[src_idx], y0 = y_pos[src_idx], |
| 354 | 212x |
x1 = x_pos[tgt_idx], y1 = y_pos[tgt_idx], |
| 355 | 212x |
lty = between_style, |
| 356 | 212x |
col = edge_col, |
| 357 | 212x |
lwd = lwd |
| 358 |
) |
|
| 359 |
} |
|
| 360 |
} |
|
| 361 |
} |
|
| 362 | ||
| 363 |
# Edges from this layer to next layer (below) |
|
| 364 | 43x |
for (src_idx in idx) {
|
| 365 | 124x |
for (tgt_idx in next_idx) {
|
| 366 | 381x |
weight <- weights[src_idx, tgt_idx] |
| 367 | 381x |
if (!is.na(weight) && weight > minimum) {
|
| 368 | 212x |
lwd <- (0.3 + 1.2 * (abs(weight) / max_w)) * edge_scale |
| 369 | 212x |
edge_col <- grDevices::adjustcolor(edge_colors[i], alpha.f = 0.6) |
| 370 | 212x |
graphics::segments( |
| 371 | 212x |
x0 = x_pos[src_idx], y0 = y_pos[src_idx], |
| 372 | 212x |
x1 = x_pos[tgt_idx], y1 = y_pos[tgt_idx], |
| 373 | 212x |
lty = between_style, |
| 374 | 212x |
col = edge_col, |
| 375 | 212x |
lwd = lwd |
| 376 |
) |
|
| 377 |
} |
|
| 378 |
} |
|
| 379 |
} |
|
| 380 |
} |
|
| 381 | ||
| 382 |
# --- Draw layer shell (parallelogram) --- |
|
| 383 | 87x |
if (isTRUE(show_border)) {
|
| 384 | 85x |
fill_color <- grDevices::adjustcolor(layer_colors[i], alpha.f = 0.3) |
| 385 | 85x |
border_color <- grDevices::adjustcolor(layer_colors[i], alpha.f = 0.9) |
| 386 | ||
| 387 | 85x |
graphics::polygon( |
| 388 | 85x |
x = c(corners[, 1], corners[1, 1]), |
| 389 | 85x |
y = c(corners[, 2], corners[1, 2]), |
| 390 | 85x |
border = border_color, |
| 391 | 85x |
col = fill_color, |
| 392 | 85x |
lwd = 1.5 * edge_scale |
| 393 |
) |
|
| 394 | ||
| 395 |
# Layer label on the right |
|
| 396 | 85x |
layer_names <- names(layer_list) |
| 397 | 85x |
if (!is.null(layer_names)) {
|
| 398 | 79x |
label_x <- max(corners[, 1]) + 0.3 |
| 399 | 79x |
label_y <- plane$center_y |
| 400 | 79x |
graphics::text( |
| 401 | 79x |
x = label_x, y = label_y, |
| 402 | 79x |
labels = layer_names[i], |
| 403 | 79x |
adj = 0, |
| 404 | 79x |
col = layer_colors[i], |
| 405 | 79x |
font = 2, |
| 406 | 79x |
cex = 1.1 / size_scale |
| 407 |
) |
|
| 408 |
} |
|
| 409 |
} |
|
| 410 | ||
| 411 |
# --- Draw within-layer edges --- |
|
| 412 | 87x |
if (isTRUE(within_edges)) {
|
| 413 | 85x |
for (src in idx) {
|
| 414 | 248x |
for (tgt in idx) {
|
| 415 | 774x |
if (src != tgt) {
|
| 416 | 526x |
weight <- weights[src, tgt] |
| 417 | 526x |
if (!is.na(weight) && weight > minimum) {
|
| 418 | 388x |
x0 <- x_pos[src] |
| 419 | 388x |
y0 <- y_pos[src] |
| 420 | 388x |
x1 <- x_pos[tgt] |
| 421 | 388x |
y1 <- y_pos[tgt] |
| 422 | ||
| 423 | 388x |
dx <- x1 - x0 |
| 424 | 388x |
dy <- y1 - y0 |
| 425 | 388x |
len <- sqrt(dx^2 + dy^2) |
| 426 | ||
| 427 | 388x |
if (len > 0) {
|
| 428 |
# Curve perpendicular to the line |
|
| 429 | 388x |
mid_x <- (x0 + x1) / 2 |
| 430 | 388x |
mid_y <- (y0 + y1) / 2 |
| 431 | 388x |
off_x <- -dy / len * curvature * len |
| 432 | 388x |
off_y <- dx / len * curvature * len |
| 433 | ||
| 434 | 388x |
edge_col <- grDevices::adjustcolor( |
| 435 | 388x |
layer_colors[i], red.f = 0.6, green.f = 0.6, blue.f = 0.6 |
| 436 |
) |
|
| 437 | 388x |
lwd <- (0.3 + 1.0 * (abs(weight) / max_w)) * edge_scale |
| 438 | ||
| 439 | 388x |
graphics::xspline( |
| 440 | 388x |
x = c(x0, mid_x + off_x, x1), |
| 441 | 388x |
y = c(y0, mid_y + off_y, y1), |
| 442 | 388x |
shape = 1, open = TRUE, |
| 443 | 388x |
border = edge_col, lwd = lwd |
| 444 |
) |
|
| 445 | ||
| 446 |
# Arrowhead |
|
| 447 | 388x |
angle <- atan2(y1 - (mid_y + off_y), x1 - (mid_x + off_x)) |
| 448 | 388x |
arrow_len <- 0.08 |
| 449 | 388x |
graphics::polygon( |
| 450 | 388x |
x = x1 + arrow_len * c(0, -cos(angle - pi/7), -cos(angle + pi/7)), |
| 451 | 388x |
y = y1 + arrow_len * c(0, -sin(angle - pi/7), -sin(angle + pi/7)), |
| 452 | 388x |
col = edge_col, border = edge_col |
| 453 |
) |
|
| 454 |
} |
|
| 455 |
} |
|
| 456 |
} |
|
| 457 |
} |
|
| 458 |
} |
|
| 459 |
} |
|
| 460 | ||
| 461 |
# --- Draw nodes --- |
|
| 462 | 87x |
pch_val <- switch(layer_shapes[i], |
| 463 | 87x |
"circle" = 21, "square" = 22, "diamond" = 23, "triangle" = 24, |
| 464 | 87x |
21 |
| 465 |
) |
|
| 466 | ||
| 467 | 87x |
graphics::points( |
| 468 | 87x |
x_pos[idx], y_pos[idx], |
| 469 | 87x |
pch = pch_val, |
| 470 | 87x |
bg = layer_colors[i], |
| 471 | 87x |
col = "gray20", |
| 472 | 87x |
cex = node_size, |
| 473 | 87x |
lwd = 0.8 * edge_scale |
| 474 |
) |
|
| 475 | ||
| 476 |
# Node labels |
|
| 477 | 87x |
graphics::text( |
| 478 | 87x |
x_pos[idx], y_pos[idx], |
| 479 | 87x |
labels = lab[idx], |
| 480 | 87x |
cex = 0.75 / size_scale, |
| 481 | 87x |
pos = 3, |
| 482 | 87x |
offset = 0.6, |
| 483 | 87x |
font = 1 |
| 484 |
) |
|
| 485 |
} |
|
| 486 | ||
| 487 |
# ========================================================================== |
|
| 488 |
# 6. Draw Legend |
|
| 489 |
# ========================================================================== |
|
| 490 | ||
| 491 | 43x |
if (isTRUE(legend)) {
|
| 492 | 40x |
layer_names <- names(layer_list) |
| 493 | 40x |
if (is.null(layer_names)) {
|
| 494 | 3x |
layer_names <- paste0("Layer ", seq_len(n_layers))
|
| 495 |
} |
|
| 496 | ||
| 497 | 40x |
shape_to_pch <- c( |
| 498 | 40x |
"circle" = 21, "square" = 22, "diamond" = 23, "triangle" = 24, |
| 499 | 40x |
"pentagon" = 21, "hexagon" = 21, "star" = 8, "cross" = 3 |
| 500 |
) |
|
| 501 | ||
| 502 | 40x |
pch_values <- sapply(layer_shapes, function(s) {
|
| 503 | 2x |
if (s %in% names(shape_to_pch)) shape_to_pch[s] else 21 |
| 504 |
}) |
|
| 505 | ||
| 506 | 40x |
graphics::legend( |
| 507 | 40x |
legend_position, |
| 508 | 40x |
legend = layer_names, |
| 509 | 40x |
pch = pch_values, |
| 510 | 40x |
pt.bg = layer_colors, |
| 511 | 40x |
col = edge_colors, |
| 512 | 40x |
pt.cex = 2.5 / size_scale, |
| 513 | 40x |
cex = 1.4 / size_scale, |
| 514 | 40x |
bty = "n", |
| 515 | 40x |
title = "Layers" |
| 516 |
) |
|
| 517 |
} |
|
| 518 | ||
| 519 | 43x |
invisible(NULL) |
| 520 |
} |
|
| 521 | ||
| 522 |
#' @rdname plot_mlna |
|
| 523 |
#' @export |
|
| 524 |
mlna <- plot_mlna |
| 1 |
#' @title Fruchterman-Reingold Spring Layout |
|
| 2 |
#' @description Force-directed layout using the Fruchterman-Reingold algorithm. |
|
| 3 |
#' @name layout-spring |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Fruchterman-Reingold Spring Layout |
|
| 7 |
#' |
|
| 8 |
#' Compute node positions using the Fruchterman-Reingold force-directed |
|
| 9 |
#' algorithm. Nodes connected by edges are attracted to each other while |
|
| 10 |
#' all nodes repel each other. |
|
| 11 |
#' |
|
| 12 |
#' @param network A CographNetwork object. |
|
| 13 |
#' @param iterations Number of iterations (default: 500). |
|
| 14 |
#' @param cooling Rate of temperature decrease (default: 0.95). |
|
| 15 |
#' @param repulsion Repulsion constant (default: 1). |
|
| 16 |
#' @param attraction Attraction constant (default: 1). |
|
| 17 |
#' @param seed Random seed for reproducibility. |
|
| 18 |
#' @param initial Optional initial coordinates (matrix or data frame). |
|
| 19 |
#' @return Data frame with x, y coordinates. |
|
| 20 |
#' @export |
|
| 21 |
#' |
|
| 22 |
#' @examples |
|
| 23 |
#' adj <- matrix(c(0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0), nrow = 4) |
|
| 24 |
#' net <- CographNetwork$new(adj) |
|
| 25 |
#' coords <- layout_spring(net, seed = 42) |
|
| 26 |
layout_spring <- function(network, iterations = 500, cooling = 0.95, |
|
| 27 |
repulsion = 1, attraction = 1, seed = NULL, |
|
| 28 |
initial = NULL) {
|
|
| 29 | ||
| 30 | 768x |
n <- network$n_nodes |
| 31 | ||
| 32 | 768x |
if (n == 0) {
|
| 33 | 1x |
return(data.frame(x = numeric(0), y = numeric(0))) |
| 34 |
} |
|
| 35 | ||
| 36 | 767x |
if (n == 1) {
|
| 37 | 16x |
return(data.frame(x = 0.5, y = 0.5)) |
| 38 |
} |
|
| 39 | ||
| 40 |
# Set seed if provided |
|
| 41 | 751x |
if (!is.null(seed)) {
|
| 42 | 8x |
set.seed(seed) |
| 43 |
} |
|
| 44 | ||
| 45 |
# Initialize positions |
|
| 46 | 751x |
if (!is.null(initial)) {
|
| 47 | 2x |
if (is.matrix(initial)) {
|
| 48 | 1x |
pos <- initial |
| 49 |
} else {
|
|
| 50 | 1x |
pos <- as.matrix(initial[, c("x", "y")])
|
| 51 |
} |
|
| 52 |
} else {
|
|
| 53 |
# Random initial positions |
|
| 54 | 749x |
pos <- cbind( |
| 55 | 749x |
x = stats::runif(n), |
| 56 | 749x |
y = stats::runif(n) |
| 57 |
) |
|
| 58 |
} |
|
| 59 | ||
| 60 |
# Get edges |
|
| 61 | 751x |
edges <- network$get_edges() |
| 62 | 751x |
if (is.null(edges) || nrow(edges) == 0) {
|
| 63 |
# No edges: return random positions |
|
| 64 | 11x |
return(data.frame(x = pos[, 1], y = pos[, 2])) |
| 65 |
} |
|
| 66 | ||
| 67 |
# Optimal distance |
|
| 68 | 740x |
area <- 1 |
| 69 | 740x |
k <- sqrt(area / n) |
| 70 | ||
| 71 |
# Temperature (controls maximum displacement) |
|
| 72 | 740x |
temp <- sqrt(area) * 0.1 |
| 73 | ||
| 74 |
# Fruchterman-Reingold iterations |
|
| 75 | 740x |
for (iter in seq_len(iterations)) {
|
| 76 |
# Initialize displacement vectors |
|
| 77 | 366365x |
disp <- matrix(0, nrow = n, ncol = 2) |
| 78 | ||
| 79 |
# Calculate repulsive forces between all pairs |
|
| 80 | 366365x |
for (i in seq_len(n - 1)) {
|
| 81 | 1004295x |
for (j in (i + 1):n) {
|
| 82 | 2004355x |
delta <- pos[i, ] - pos[j, ] |
| 83 | 2004355x |
dist <- sqrt(sum(delta^2)) |
| 84 | 2493x |
if (dist < 0.001) dist <- 0.001 # Avoid division by zero |
| 85 | ||
| 86 |
# Repulsive force |
|
| 87 | 2004355x |
force <- repulsion * k^2 / dist |
| 88 | 2004355x |
disp_vec <- (delta / dist) * force |
| 89 | ||
| 90 | 2004355x |
disp[i, ] <- disp[i, ] + disp_vec |
| 91 | 2004355x |
disp[j, ] <- disp[j, ] - disp_vec |
| 92 |
} |
|
| 93 |
} |
|
| 94 | ||
| 95 |
# Calculate attractive forces along edges |
|
| 96 | 366365x |
for (e in seq_len(nrow(edges))) {
|
| 97 | 1177270x |
i <- edges$from[e] |
| 98 | 1177270x |
j <- edges$to[e] |
| 99 | ||
| 100 | 1177270x |
delta <- pos[i, ] - pos[j, ] |
| 101 | 1177270x |
dist <- sqrt(sum(delta^2)) |
| 102 | 5262x |
if (dist < 0.001) dist <- 0.001 |
| 103 | ||
| 104 |
# Attractive force (weighted) |
|
| 105 | 1177270x |
weight <- if (!is.null(edges$weight)) abs(edges$weight[e]) else 1 |
| 106 | 1177270x |
force <- attraction * dist^2 / k * weight |
| 107 | 1177270x |
disp_vec <- (delta / dist) * force |
| 108 | ||
| 109 | 1177270x |
disp[i, ] <- disp[i, ] - disp_vec |
| 110 | 1177270x |
disp[j, ] <- disp[j, ] + disp_vec |
| 111 |
} |
|
| 112 | ||
| 113 |
# Apply displacement with temperature limit |
|
| 114 | 366365x |
for (i in seq_len(n)) {
|
| 115 | 1370660x |
disp_len <- sqrt(sum(disp[i, ]^2)) |
| 116 | 1370660x |
if (disp_len > 0) {
|
| 117 |
# Limit displacement to temperature |
|
| 118 | 1370660x |
scale <- min(disp_len, temp) / disp_len |
| 119 | 1370660x |
pos[i, ] <- pos[i, ] + disp[i, ] * scale |
| 120 |
} |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# Keep within bounds [0, 1] |
|
| 124 | 366365x |
pos[, 1] <- pmin(pmax(pos[, 1], 0.05), 0.95) |
| 125 | 366365x |
pos[, 2] <- pmin(pmax(pos[, 2], 0.05), 0.95) |
| 126 | ||
| 127 |
# Cool down |
|
| 128 | 366365x |
temp <- temp * cooling |
| 129 |
} |
|
| 130 | ||
| 131 | 740x |
data.frame(x = pos[, 1], y = pos[, 2]) |
| 132 |
} |
| 1 |
#' @title Geometry Utilities |
|
| 2 |
#' @description Utility functions for geometric calculations. |
|
| 3 |
#' @name utils-geometry |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Calculate Distance Between Two Points |
|
| 8 |
#' |
|
| 9 |
#' @param x1,y1 First point coordinates. |
|
| 10 |
#' @param x2,y2 Second point coordinates. |
|
| 11 |
#' @return Euclidean distance. |
|
| 12 |
#' @keywords internal |
|
| 13 |
point_distance <- function(x1, y1, x2, y2) {
|
|
| 14 | 3x |
sqrt((x2 - x1)^2 + (y2 - y1)^2) |
| 15 |
} |
|
| 16 | ||
| 17 |
#' Calculate Angle Between Two Points |
|
| 18 |
#' |
|
| 19 |
#' @param x1,y1 Start point coordinates. |
|
| 20 |
#' @param x2,y2 End point coordinates. |
|
| 21 |
#' @return Angle in radians. |
|
| 22 |
#' @keywords internal |
|
| 23 |
point_angle <- function(x1, y1, x2, y2) {
|
|
| 24 | 6x |
atan2(y2 - y1, x2 - x1) |
| 25 |
} |
|
| 26 | ||
| 27 |
#' Calculate Point on Circle |
|
| 28 |
#' |
|
| 29 |
#' @param cx,cy Center coordinates. |
|
| 30 |
#' @param r Radius. |
|
| 31 |
#' @param angle Angle in radians. |
|
| 32 |
#' @return List with x, y coordinates. |
|
| 33 |
#' @keywords internal |
|
| 34 |
point_on_circle <- function(cx, cy, r, angle) {
|
|
| 35 | 3x |
list( |
| 36 | 3x |
x = cx + r * cos(angle), |
| 37 | 3x |
y = cy + r * sin(angle) |
| 38 |
) |
|
| 39 |
} |
|
| 40 | ||
| 41 |
#' Calculate Bezier Curve Points |
|
| 42 |
#' |
|
| 43 |
#' Calculate points along a quadratic Bezier curve. |
|
| 44 |
#' |
|
| 45 |
#' @param x0,y0 Start point. |
|
| 46 |
#' @param x1,y1 Control point. |
|
| 47 |
#' @param x2,y2 End point. |
|
| 48 |
#' @param n Number of points to generate. |
|
| 49 |
#' @return Data frame with x, y coordinates. |
|
| 50 |
#' @keywords internal |
|
| 51 |
bezier_points <- function(x0, y0, x1, y1, x2, y2, n = 50) {
|
|
| 52 | 227x |
t <- seq(0, 1, length.out = n) |
| 53 | ||
| 54 |
# Quadratic Bezier formula |
|
| 55 | 227x |
x <- (1 - t)^2 * x0 + 2 * (1 - t) * t * x1 + t^2 * x2 |
| 56 | 227x |
y <- (1 - t)^2 * y0 + 2 * (1 - t) * t * y1 + t^2 * y2 |
| 57 | ||
| 58 | 227x |
data.frame(x = x, y = y) |
| 59 |
} |
|
| 60 | ||
| 61 |
#' Calculate Control Point for Curved Edge |
|
| 62 |
#' |
|
| 63 |
#' @param x1,y1 Start point. |
|
| 64 |
#' @param x2,y2 End point. |
|
| 65 |
#' @param curvature Curvature amount (0 = straight line). |
|
| 66 |
#' @param pivot Position along edge (0-1) where control point sits. 0 = near source, |
|
| 67 |
#' 0.5 = middle (default), 1 = near target. |
|
| 68 |
#' @param shape Spline tension affecting curvature intensity (-1 to 1). |
|
| 69 |
#' Negative = sharper curve, Positive = gentler curve. Default 0. |
|
| 70 |
#' @return List with x, y coordinates of control point. |
|
| 71 |
#' @keywords internal |
|
| 72 |
curve_control_point <- function(x1, y1, x2, y2, curvature, pivot = 0.5, shape = 0) {
|
|
| 73 |
# Point along the edge based on pivot (0 = source, 0.5 = midpoint, 1 = target) |
|
| 74 | 278x |
pivot <- max(0, min(1, pivot)) # Clamp to [0, 1] |
| 75 | 278x |
mx <- x1 + pivot * (x2 - x1) |
| 76 | 278x |
my <- y1 + pivot * (y2 - y1) |
| 77 | ||
| 78 |
# Perpendicular offset |
|
| 79 | 278x |
dx <- x2 - x1 |
| 80 | 278x |
dy <- y2 - y1 |
| 81 | 278x |
len <- sqrt(dx^2 + dy^2) |
| 82 | ||
| 83 | 278x |
if (len == 0) {
|
| 84 | 1x |
return(list(x = mx, y = my)) |
| 85 |
} |
|
| 86 | ||
| 87 |
# Perpendicular unit vector |
|
| 88 | 277x |
px <- -dy / len |
| 89 | 277x |
py <- dx / len |
| 90 | ||
| 91 |
# Adjust curvature based on shape parameter |
|
| 92 |
# shape = 0: no adjustment |
|
| 93 |
# shape < 0: sharper curve (increase curvature magnitude) |
|
| 94 |
# shape > 0: gentler curve (decrease curvature magnitude) |
|
| 95 | 277x |
shape <- max(-1, min(1, shape)) # Clamp to [-1, 1] |
| 96 | 277x |
adjusted_curvature <- curvature * (1 - shape * 0.5) |
| 97 | ||
| 98 |
# Control point |
|
| 99 | 277x |
list( |
| 100 | 277x |
x = mx + adjusted_curvature * len * px, |
| 101 | 277x |
y = my + adjusted_curvature * len * py |
| 102 |
) |
|
| 103 |
} |
|
| 104 | ||
| 105 |
#' Calculate Arrow Head Points |
|
| 106 |
#' |
|
| 107 |
#' @param x,y Arrow tip position. |
|
| 108 |
#' @param angle Angle of incoming edge (radians). |
|
| 109 |
#' @param size Arrow size. |
|
| 110 |
#' @param width Arrow width ratio (default 0.5). |
|
| 111 |
#' @param x_scale,y_scale Aspect ratio correction factors. |
|
| 112 |
#' @return List with arrow polygon coordinates and midpoint for line connection. |
|
| 113 |
#' @keywords internal |
|
| 114 |
arrow_points <- function(x, y, angle, size, width = 0.5, x_scale = 1, y_scale = 1) {
|
|
| 115 | ||
| 116 |
# Arrow points relative to tip |
|
| 117 | 279x |
left_angle <- angle + pi - atan(width) |
| 118 | 279x |
right_angle <- angle + pi + atan(width) |
| 119 | 279x |
back_len <- size / cos(atan(width)) |
| 120 | ||
| 121 | 279x |
left_x <- x + back_len * cos(left_angle) * x_scale |
| 122 | 279x |
left_y <- y + back_len * sin(left_angle) * y_scale |
| 123 | 279x |
right_x <- x + back_len * cos(right_angle) * x_scale |
| 124 | 279x |
right_y <- y + back_len * sin(right_angle) * y_scale |
| 125 | ||
| 126 |
# Midpoint of the arrow base (where line should connect) |
|
| 127 | 279x |
mid_x <- (left_x + right_x) / 2 |
| 128 | 279x |
mid_y <- (left_y + right_y) / 2 |
| 129 | ||
| 130 | 279x |
list( |
| 131 | 279x |
x = c(x, left_x, right_x), |
| 132 | 279x |
y = c(y, left_y, right_y), |
| 133 | 279x |
mid_x = mid_x, |
| 134 | 279x |
mid_y = mid_y, |
| 135 | 279x |
back_len = back_len |
| 136 |
) |
|
| 137 |
} |
|
| 138 | ||
| 139 |
#' Offset Point from Center |
|
| 140 |
#' |
|
| 141 |
#' Calculate a point offset from another point by a given distance. |
|
| 142 |
#' |
|
| 143 |
#' @param x,y Original point. |
|
| 144 |
#' @param toward_x,toward_y Point to offset toward. |
|
| 145 |
#' @param offset Distance to offset. |
|
| 146 |
#' @return List with x, y coordinates. |
|
| 147 |
#' @keywords internal |
|
| 148 |
offset_point <- function(x, y, toward_x, toward_y, offset) {
|
|
| 149 | 2x |
angle <- point_angle(x, y, toward_x, toward_y) |
| 150 | 2x |
list( |
| 151 | 2x |
x = x + offset * cos(angle), |
| 152 | 2x |
y = y + offset * sin(angle) |
| 153 |
) |
|
| 154 |
} |
|
| 155 | ||
| 156 |
#' Calculate Edge Endpoint on Node Border |
|
| 157 |
#' |
|
| 158 |
#' Calculates the point where an edge should meet the node border. |
|
| 159 |
#' Uses plain NPC units to match circleGrob borders. |
|
| 160 |
#' |
|
| 161 |
#' @param node_x,node_y Node center in npc. |
|
| 162 |
#' @param other_x,other_y Other endpoint in npc. |
|
| 163 |
#' @param node_size Node radius in npc units. |
|
| 164 |
#' @param shape Node shape. |
|
| 165 |
#' @param x_scale,y_scale Aspect ratio correction factors. |
|
| 166 |
#' @return List with x, y coordinates in npc. |
|
| 167 |
#' @keywords internal |
|
| 168 |
edge_endpoint <- function(node_x, node_y, other_x, other_y, node_size, |
|
| 169 |
shape = "circle", x_scale = 1, y_scale = 1) {
|
|
| 170 |
# Calculate angle from node center to other point, accounting for aspect ratio |
|
| 171 | 4552x |
dx <- (other_x - node_x) / x_scale |
| 172 | 4552x |
dy <- (other_y - node_y) / y_scale |
| 173 | 4552x |
angle <- atan2(dy, dx) |
| 174 | ||
| 175 |
# Point on node border with aspect correction |
|
| 176 | 4552x |
list( |
| 177 | 4552x |
x = node_x + node_size * cos(angle) * x_scale, |
| 178 | 4552x |
y = node_y + node_size * sin(angle) * y_scale |
| 179 |
) |
|
| 180 |
} |
| 1 |
#' @title Edge Label Template Formatting |
|
| 2 |
#' @description Functions for formatting edge labels using templates with placeholders. |
|
| 3 |
#' @name splot-labels |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Get Significance Stars from P-values |
|
| 8 |
#' |
|
| 9 |
#' Converts p-values to significance stars following conventional thresholds. |
|
| 10 |
#' |
|
| 11 |
#' @param p Numeric p-value(s). |
|
| 12 |
#' @return Character vector of stars. |
|
| 13 |
#' @keywords internal |
|
| 14 |
get_significance_stars <- function(p) {
|
|
| 15 | 1x |
if (is.null(p)) return(NULL) |
| 16 | ||
| 17 | 12x |
vapply(p, function(pval) {
|
| 18 | 1x |
if (is.na(pval)) return("")
|
| 19 | 5x |
if (pval < 0.001) return("***")
|
| 20 | 5x |
if (pval < 0.01) return("**")
|
| 21 | 5x |
if (pval < 0.05) return("*")
|
| 22 | 5x |
return("")
|
| 23 | 12x |
}, character(1)) |
| 24 |
} |
|
| 25 | ||
| 26 |
#' Format P-value |
|
| 27 |
#' |
|
| 28 |
#' Formats a p-value with specified decimal places and prefix. |
|
| 29 |
#' |
|
| 30 |
#' @param p Numeric p-value. |
|
| 31 |
#' @param digits Number of decimal places. |
|
| 32 |
#' @param prefix Prefix string (e.g., "p="). |
|
| 33 |
#' @return Formatted p-value string. |
|
| 34 |
#' @keywords internal |
|
| 35 |
format_pvalue <- function(p, digits = 3, prefix = "p=") {
|
|
| 36 | 2x |
if (is.null(p) || is.na(p)) return("")
|
| 37 | ||
| 38 | 9x |
if (p < 10^(-digits)) {
|
| 39 | 1x |
paste0(prefix, "<", format(10^(-digits), nsmall = digits)) |
| 40 |
} else {
|
|
| 41 | 8x |
paste0(prefix, format(round(p, digits), nsmall = digits)) |
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 |
#' Format CI Range |
|
| 46 |
#' |
|
| 47 |
#' Formats confidence interval bounds as a range string. |
|
| 48 |
#' |
|
| 49 |
#' @param lower Lower bound. |
|
| 50 |
#' @param upper Upper bound. |
|
| 51 |
#' @param digits Number of decimal places. |
|
| 52 |
#' @param format CI format: "bracket" for `[low, up]` or "dash" for `low-up`. |
|
| 53 |
#' @return Formatted CI range string. |
|
| 54 |
#' @keywords internal |
|
| 55 |
format_ci_range <- function(lower, upper, digits = 2, format = "bracket") {
|
|
| 56 | 18x |
if (is.null(lower) || is.null(upper) || is.na(lower) || is.na(upper)) {
|
| 57 | 9x |
return("")
|
| 58 |
} |
|
| 59 | ||
| 60 | 9x |
low_str <- format(round(lower, digits), nsmall = digits) |
| 61 | 9x |
up_str <- format(round(upper, digits), nsmall = digits) |
| 62 | ||
| 63 | 9x |
if (format == "bracket") {
|
| 64 | 7x |
paste0("[", low_str, ", ", up_str, "]")
|
| 65 |
} else {
|
|
| 66 | 2x |
paste0(low_str, "-", up_str) |
| 67 |
} |
|
| 68 |
} |
|
| 69 | ||
| 70 |
#' Resolve Stars from Various Inputs |
|
| 71 |
#' |
|
| 72 |
#' Resolves significance stars from character vectors, logical, or p-values. |
|
| 73 |
#' |
|
| 74 |
#' @param stars_input User input: character vector, logical, or numeric p-values. |
|
| 75 |
#' @param p_values P-values for computing stars if stars_input is TRUE/numeric. |
|
| 76 |
#' @param n Number of edges. |
|
| 77 |
#' @return Character vector of stars. |
|
| 78 |
#' @keywords internal |
|
| 79 |
resolve_stars <- function(stars_input, p_values = NULL, n) {
|
|
| 80 | 21x |
if (is.null(stars_input)) {
|
| 81 | 13x |
return(rep("", n))
|
| 82 |
} |
|
| 83 | ||
| 84 |
# If logical TRUE, compute from p-values |
|
| 85 | 8x |
if (is.logical(stars_input) && length(stars_input) == 1 && stars_input) {
|
| 86 | 2x |
if (is.null(p_values)) {
|
| 87 | 1x |
return(rep("", n))
|
| 88 |
} |
|
| 89 | 1x |
return(get_significance_stars(p_values)) |
| 90 |
} |
|
| 91 | ||
| 92 |
# If logical FALSE, no stars |
|
| 93 | 6x |
if (is.logical(stars_input) && length(stars_input) == 1 && !stars_input) {
|
| 94 | 1x |
return(rep("", n))
|
| 95 |
} |
|
| 96 | ||
| 97 |
# If numeric, treat as p-values |
|
| 98 | 5x |
if (is.numeric(stars_input)) {
|
| 99 | 1x |
return(get_significance_stars(stars_input)) |
| 100 |
} |
|
| 101 | ||
| 102 |
# If character, use directly |
|
| 103 | 4x |
if (is.character(stars_input)) {
|
| 104 | 3x |
return(recycle_to_length(stars_input, n)) |
| 105 |
} |
|
| 106 | ||
| 107 | 1x |
rep("", n)
|
| 108 |
} |
|
| 109 | ||
| 110 |
#' Format Edge Label from Template |
|
| 111 |
#' |
|
| 112 |
#' Processes a template string with placeholders and substitutes values. |
|
| 113 |
#' |
|
| 114 |
#' @param template Template string with placeholders: \{est\}, \{range\}, \{low\}, \{up\}, \{p\}, \{stars\}.
|
|
| 115 |
#' @param weight Edge weight (estimate). |
|
| 116 |
#' @param ci_lower Lower CI bound. |
|
| 117 |
#' @param ci_upper Upper CI bound. |
|
| 118 |
#' @param p_value P-value. |
|
| 119 |
#' @param stars Significance stars string. |
|
| 120 |
#' @param digits Decimal places for estimates. |
|
| 121 |
#' @param p_digits Decimal places for p-values. |
|
| 122 |
#' @param p_prefix Prefix for p-values. |
|
| 123 |
#' @param ci_format CI format: "bracket" or "dash". |
|
| 124 |
#' @param oneline Logical: single line format (space-separated) or multiline. |
|
| 125 |
#' @return Formatted label string. |
|
| 126 |
#' @keywords internal |
|
| 127 |
format_edge_label_template <- function(template, |
|
| 128 |
weight = NA, |
|
| 129 |
ci_lower = NA, |
|
| 130 |
ci_upper = NA, |
|
| 131 |
p_value = NA, |
|
| 132 |
stars = "", |
|
| 133 |
digits = 2, |
|
| 134 |
p_digits = 3, |
|
| 135 |
p_prefix = "p=", |
|
| 136 |
ci_format = "bracket", |
|
| 137 |
oneline = TRUE) {
|
|
| 138 | 44x |
if (is.null(template) || template == "") {
|
| 139 | 2x |
return("")
|
| 140 |
} |
|
| 141 | ||
| 142 | 42x |
result <- template |
| 143 | ||
| 144 |
# Replace {est} - estimate/weight
|
|
| 145 | 42x |
if (grepl("\\{est\\}", result)) {
|
| 146 | 32x |
est_str <- if (!is.na(weight)) {
|
| 147 | 31x |
format(round(weight, digits), nsmall = digits) |
| 148 |
} else {
|
|
| 149 |
"" |
|
| 150 |
} |
|
| 151 | 32x |
result <- gsub("\\{est\\}", est_str, result)
|
| 152 |
} |
|
| 153 | ||
| 154 |
# Replace {range} - full CI range [low, up]
|
|
| 155 | 42x |
if (grepl("\\{range\\}", result)) {
|
| 156 | 9x |
range_str <- format_ci_range(ci_lower, ci_upper, digits, ci_format) |
| 157 | 9x |
result <- gsub("\\{range\\}", range_str, result)
|
| 158 |
} |
|
| 159 | ||
| 160 |
# Replace {low} - CI lower bound only
|
|
| 161 | 42x |
if (grepl("\\{low\\}", result)) {
|
| 162 | 5x |
low_str <- if (!is.na(ci_lower)) {
|
| 163 | 4x |
format(round(ci_lower, digits), nsmall = digits) |
| 164 |
} else {
|
|
| 165 |
"" |
|
| 166 |
} |
|
| 167 | 5x |
result <- gsub("\\{low\\}", low_str, result)
|
| 168 |
} |
|
| 169 | ||
| 170 |
# Replace {up} - CI upper bound only
|
|
| 171 | 42x |
if (grepl("\\{up\\}", result)) {
|
| 172 | 5x |
up_str <- if (!is.na(ci_upper)) {
|
| 173 | 4x |
format(round(ci_upper, digits), nsmall = digits) |
| 174 |
} else {
|
|
| 175 |
"" |
|
| 176 |
} |
|
| 177 | 5x |
result <- gsub("\\{up\\}", up_str, result)
|
| 178 |
} |
|
| 179 | ||
| 180 |
# Replace {p} - p-value
|
|
| 181 | 42x |
if (grepl("\\{p\\}", result)) {
|
| 182 | 3x |
p_str <- format_pvalue(p_value, p_digits, p_prefix) |
| 183 | 3x |
result <- gsub("\\{p\\}", p_str, result)
|
| 184 |
} |
|
| 185 | ||
| 186 |
# Replace {stars} - significance stars
|
|
| 187 | 42x |
if (grepl("\\{stars\\}", result)) {
|
| 188 | 6x |
stars_str <- if (!is.null(stars) && !is.na(stars)) stars else "" |
| 189 | 6x |
result <- gsub("\\{stars\\}", stars_str, result)
|
| 190 |
} |
|
| 191 | ||
| 192 |
# Clean up extra whitespace |
|
| 193 | 42x |
result <- trimws(result) |
| 194 | 42x |
result <- gsub("\\s+", " ", result)
|
| 195 | ||
| 196 | 42x |
result |
| 197 |
} |
|
| 198 | ||
| 199 |
#' Get Template from Style Preset |
|
| 200 |
#' |
|
| 201 |
#' Converts a style preset name to its corresponding template string. |
|
| 202 |
#' |
|
| 203 |
#' @param style Style preset: "none", "estimate", "full", "range", "stars". |
|
| 204 |
#' @return Template string or NULL for "none". |
|
| 205 |
#' @keywords internal |
|
| 206 |
get_template_from_style <- function(style) {
|
|
| 207 | 13x |
switch(style, |
| 208 | 2x |
"none" = NULL, |
| 209 | 4x |
"estimate" = "{est}",
|
| 210 | 2x |
"full" = "{est} {range}",
|
| 211 | 1x |
"range" = "{range}",
|
| 212 | 2x |
"stars" = "{stars}",
|
| 213 | 2x |
NULL |
| 214 |
) |
|
| 215 |
} |
|
| 216 | ||
| 217 |
#' Build Edge Labels from Template |
|
| 218 |
#' |
|
| 219 |
#' Generates edge labels for all edges using template formatting. |
|
| 220 |
#' |
|
| 221 |
#' @param template Template string or NULL. |
|
| 222 |
#' @param style Style preset (used if template is NULL). |
|
| 223 |
#' @param weights Edge weights/estimates. |
|
| 224 |
#' @param ci_lower Lower CI bounds (vector). |
|
| 225 |
#' @param ci_upper Upper CI bounds (vector). |
|
| 226 |
#' @param p_values P-values (vector). |
|
| 227 |
#' @param stars Stars input (character vector, logical, or numeric p-values). |
|
| 228 |
#' @param digits Decimal places for estimates. |
|
| 229 |
#' @param p_digits Decimal places for p-values. |
|
| 230 |
#' @param p_prefix Prefix for p-values. |
|
| 231 |
#' @param ci_format CI format: "bracket" or "dash". |
|
| 232 |
#' @param oneline Logical: single line format. |
|
| 233 |
#' @param n Number of edges. |
|
| 234 |
#' @return Character vector of formatted labels. |
|
| 235 |
#' @keywords internal |
|
| 236 |
build_edge_labels_from_template <- function(template = NULL, |
|
| 237 |
style = "none", |
|
| 238 |
weights = NULL, |
|
| 239 |
ci_lower = NULL, |
|
| 240 |
ci_upper = NULL, |
|
| 241 |
p_values = NULL, |
|
| 242 |
stars = NULL, |
|
| 243 |
digits = 2, |
|
| 244 |
p_digits = 3, |
|
| 245 |
p_prefix = "p=", |
|
| 246 |
ci_format = "bracket", |
|
| 247 |
oneline = TRUE, |
|
| 248 |
n) {
|
|
| 249 |
# Determine template to use |
|
| 250 | 15x |
if (is.null(template)) {
|
| 251 | 7x |
template <- get_template_from_style(style) |
| 252 |
} |
|
| 253 | ||
| 254 | 15x |
if (is.null(template)) {
|
| 255 | 2x |
return(NULL) # "none" style, no labels |
| 256 |
} |
|
| 257 | ||
| 258 |
# Resolve stars |
|
| 259 | 13x |
stars_vec <- resolve_stars(stars, p_values, n) |
| 260 | ||
| 261 |
# Recycle inputs to length n |
|
| 262 | 13x |
if (!is.null(weights)) weights <- recycle_to_length(weights, n) |
| 263 | 2x |
if (!is.null(ci_lower)) ci_lower <- recycle_to_length(ci_lower, n) |
| 264 | 2x |
if (!is.null(ci_upper)) ci_upper <- recycle_to_length(ci_upper, n) |
| 265 | 3x |
if (!is.null(p_values)) p_values <- recycle_to_length(p_values, n) |
| 266 | ||
| 267 |
# Generate labels for each edge |
|
| 268 | 13x |
labels <- vapply(seq_len(n), function(i) {
|
| 269 | 30x |
format_edge_label_template( |
| 270 | 30x |
template = template, |
| 271 | 30x |
weight = if (!is.null(weights)) weights[i] else NA, |
| 272 | 30x |
ci_lower = if (!is.null(ci_lower)) ci_lower[i] else NA, |
| 273 | 30x |
ci_upper = if (!is.null(ci_upper)) ci_upper[i] else NA, |
| 274 | 30x |
p_value = if (!is.null(p_values)) p_values[i] else NA, |
| 275 | 30x |
stars = stars_vec[i], |
| 276 | 30x |
digits = digits, |
| 277 | 30x |
p_digits = p_digits, |
| 278 | 30x |
p_prefix = p_prefix, |
| 279 | 30x |
ci_format = ci_format, |
| 280 | 30x |
oneline = oneline |
| 281 |
) |
|
| 282 | 13x |
}, character(1)) |
| 283 | ||
| 284 | 13x |
labels |
| 285 |
} |
| 1 |
#' @title Color Palettes |
|
| 2 |
#' @description Built-in color palettes for network visualization. |
|
| 3 |
#' @name palettes |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Rainbow Palette |
|
| 7 |
#' |
|
| 8 |
#' Generate a rainbow color palette. |
|
| 9 |
#' |
|
| 10 |
#' @param n Number of colors to generate. |
|
| 11 |
#' @param alpha Transparency (0-1). |
|
| 12 |
#' @return Character vector of colors. |
|
| 13 |
#' @export |
|
| 14 |
#' @examples |
|
| 15 |
#' palette_rainbow(5) |
|
| 16 |
palette_rainbow <- function(n, alpha = 1) {
|
|
| 17 | 15x |
grDevices::rainbow(n, alpha = alpha) |
| 18 |
} |
|
| 19 | ||
| 20 |
#' Colorblind-friendly Palette |
|
| 21 |
#' |
|
| 22 |
#' Generate a colorblind-friendly palette using Wong's colors. |
|
| 23 |
#' |
|
| 24 |
#' @param n Number of colors to generate. |
|
| 25 |
#' @param alpha Transparency (0-1). |
|
| 26 |
#' @return Character vector of colors. |
|
| 27 |
#' @export |
|
| 28 |
#' @examples |
|
| 29 |
#' palette_colorblind(5) |
|
| 30 |
palette_colorblind <- function(n, alpha = 1) {
|
|
| 31 |
# Wong's colorblind-friendly palette |
|
| 32 | 25x |
base_colors <- c( |
| 33 | 25x |
"#000000", # Black |
| 34 | 25x |
"#E69F00", # Orange |
| 35 | 25x |
"#56B4E9", # Sky blue |
| 36 | 25x |
"#009E73", # Bluish green |
| 37 | 25x |
"#F0E442", # Yellow |
| 38 | 25x |
"#0072B2", # Blue |
| 39 | 25x |
"#D55E00", # Vermillion |
| 40 | 25x |
"#CC79A7" # Reddish purple |
| 41 |
) |
|
| 42 | ||
| 43 | 25x |
if (n <= length(base_colors)) {
|
| 44 | 22x |
colors <- base_colors[seq_len(n)] |
| 45 |
} else {
|
|
| 46 |
# Interpolate if more colors needed |
|
| 47 | 3x |
colors <- grDevices::colorRampPalette(base_colors)(n) |
| 48 |
} |
|
| 49 | ||
| 50 | 25x |
if (alpha < 1) {
|
| 51 | 1x |
colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 52 |
} |
|
| 53 | ||
| 54 | 25x |
colors |
| 55 |
} |
|
| 56 | ||
| 57 |
#' Pastel Palette |
|
| 58 |
#' |
|
| 59 |
#' Generate a soft pastel color palette. |
|
| 60 |
#' |
|
| 61 |
#' @param n Number of colors to generate. |
|
| 62 |
#' @param alpha Transparency (0-1). |
|
| 63 |
#' @return Character vector of colors. |
|
| 64 |
#' @export |
|
| 65 |
#' @examples |
|
| 66 |
#' palette_pastel(5) |
|
| 67 |
palette_pastel <- function(n, alpha = 1) {
|
|
| 68 | 16x |
base_colors <- c( |
| 69 | 16x |
"#FFB3BA", # Pastel pink |
| 70 | 16x |
"#BAFFC9", # Pastel green |
| 71 | 16x |
"#BAE1FF", # Pastel blue |
| 72 | 16x |
"#FFFFBA", # Pastel yellow |
| 73 | 16x |
"#FFDFBA", # Pastel orange |
| 74 | 16x |
"#E0BBE4", # Pastel purple |
| 75 | 16x |
"#957DAD", # Pastel violet |
| 76 | 16x |
"#FEC8D8" # Pastel rose |
| 77 |
) |
|
| 78 | ||
| 79 | 16x |
if (n <= length(base_colors)) {
|
| 80 | 13x |
colors <- base_colors[seq_len(n)] |
| 81 |
} else {
|
|
| 82 | 3x |
colors <- grDevices::colorRampPalette(base_colors)(n) |
| 83 |
} |
|
| 84 | ||
| 85 | 16x |
if (alpha < 1) {
|
| 86 | 1x |
colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 87 |
} |
|
| 88 | ||
| 89 | 16x |
colors |
| 90 |
} |
|
| 91 | ||
| 92 |
#' Viridis Palette |
|
| 93 |
#' |
|
| 94 |
#' Generate colors from the viridis palette. |
|
| 95 |
#' |
|
| 96 |
#' @param n Number of colors to generate. |
|
| 97 |
#' @param alpha Transparency (0-1). |
|
| 98 |
#' @param option Viridis option: "viridis", "magma", "plasma", "inferno", "cividis". |
|
| 99 |
#' @return Character vector of colors. |
|
| 100 |
#' @export |
|
| 101 |
#' @examples |
|
| 102 |
#' palette_viridis(5) |
|
| 103 |
palette_viridis <- function(n, alpha = 1, option = "viridis") {
|
|
| 104 |
# Pre-defined viridis endpoints |
|
| 105 | 31x |
viridis_palettes <- list( |
| 106 | 31x |
viridis = c("#440154", "#414487", "#2a788e", "#22a884", "#7ad151", "#fde725"),
|
| 107 | 31x |
magma = c("#000004", "#3b0f70", "#8c2981", "#de4968", "#fe9f6d", "#fcfdbf"),
|
| 108 | 31x |
plasma = c("#0d0887", "#6a00a8", "#b12a90", "#e16462", "#fca636", "#f0f921"),
|
| 109 | 31x |
inferno = c("#000004", "#420a68", "#932667", "#dd513a", "#fca50a", "#fcffa4"),
|
| 110 | 31x |
cividis = c("#00224e", "#123570", "#3b496c", "#575d6d", "#707173", "#8a8678")
|
| 111 |
) |
|
| 112 | ||
| 113 | 31x |
base <- viridis_palettes[[option]] |
| 114 | 1x |
if (is.null(base)) base <- viridis_palettes[["viridis"]] |
| 115 | ||
| 116 | 31x |
colors <- grDevices::colorRampPalette(base)(n) |
| 117 | ||
| 118 | 31x |
if (alpha < 1) {
|
| 119 | 1x |
colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 120 |
} |
|
| 121 | ||
| 122 | 31x |
colors |
| 123 |
} |
|
| 124 | ||
| 125 |
#' Blues Palette |
|
| 126 |
#' |
|
| 127 |
#' Generate a blue sequential palette. |
|
| 128 |
#' |
|
| 129 |
#' @param n Number of colors to generate. |
|
| 130 |
#' @param alpha Transparency (0-1). |
|
| 131 |
#' @return Character vector of colors. |
|
| 132 |
#' @export |
|
| 133 |
#' @examples |
|
| 134 |
#' palette_blues(5) |
|
| 135 |
palette_blues <- function(n, alpha = 1) {
|
|
| 136 | 9x |
base_colors <- c("#f7fbff", "#deebf7", "#c6dbef", "#9ecae1",
|
| 137 | 9x |
"#6baed6", "#4292c6", "#2171b5", "#084594") |
| 138 | 9x |
colors <- grDevices::colorRampPalette(base_colors)(n) |
| 139 | 1x |
if (alpha < 1) colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 140 | 9x |
colors |
| 141 |
} |
|
| 142 | ||
| 143 |
#' Reds Palette |
|
| 144 |
#' |
|
| 145 |
#' Generate a red sequential palette. |
|
| 146 |
#' |
|
| 147 |
#' @param n Number of colors to generate. |
|
| 148 |
#' @param alpha Transparency (0-1). |
|
| 149 |
#' @return Character vector of colors. |
|
| 150 |
#' @export |
|
| 151 |
#' @examples |
|
| 152 |
#' palette_reds(5) |
|
| 153 |
palette_reds <- function(n, alpha = 1) {
|
|
| 154 | 9x |
base_colors <- c("#fff5f0", "#fee0d2", "#fcbba1", "#fc9272",
|
| 155 | 9x |
"#fb6a4a", "#ef3b2c", "#cb181d", "#99000d") |
| 156 | 9x |
colors <- grDevices::colorRampPalette(base_colors)(n) |
| 157 | 1x |
if (alpha < 1) colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 158 | 9x |
colors |
| 159 |
} |
|
| 160 | ||
| 161 |
#' Diverging Palette |
|
| 162 |
#' |
|
| 163 |
#' Generate a diverging color palette (blue-white-red). |
|
| 164 |
#' |
|
| 165 |
#' @param n Number of colors to generate. |
|
| 166 |
#' @param alpha Transparency (0-1). |
|
| 167 |
#' @param midpoint Color for midpoint. |
|
| 168 |
#' @return Character vector of colors. |
|
| 169 |
#' @export |
|
| 170 |
#' @examples |
|
| 171 |
#' palette_diverging(5) |
|
| 172 |
palette_diverging <- function(n, alpha = 1, midpoint = "white") {
|
|
| 173 | 12x |
base_colors <- c("#2166ac", "#67a9cf", "#d1e5f0", midpoint,
|
| 174 | 12x |
"#fddbc7", "#ef8a62", "#b2182b") |
| 175 | 12x |
colors <- grDevices::colorRampPalette(base_colors)(n) |
| 176 | 1x |
if (alpha < 1) colors <- sapply(colors, adjust_alpha, alpha = alpha) |
| 177 | 12x |
colors |
| 178 |
} |
|
| 179 | ||
| 180 |
#' Register Built-in Palettes |
|
| 181 |
#' |
|
| 182 |
#' @keywords internal |
|
| 183 |
register_builtin_palettes <- function() {
|
|
| 184 | 2x |
register_palette("rainbow", palette_rainbow)
|
| 185 | 2x |
register_palette("colorblind", palette_colorblind)
|
| 186 | 2x |
register_palette("pastel", palette_pastel)
|
| 187 | 2x |
register_palette("viridis", palette_viridis)
|
| 188 | 2x |
register_palette("blues", palette_blues)
|
| 189 | 2x |
register_palette("reds", palette_reds)
|
| 190 | 2x |
register_palette("diverging", palette_diverging)
|
| 191 |
} |
| 1 |
#' @title Grid Rendering |
|
| 2 |
#' @description Main grid-based rendering functions. |
|
| 3 |
#' @keywords internal |
|
| 4 |
#' @name render-grid |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Plot Cograph Network |
|
| 8 |
#' |
|
| 9 |
#' Main plotting function for Cograph networks. Renders the network visualization |
|
| 10 |
#' using grid graphics. Accepts all node and edge aesthetic parameters. |
|
| 11 |
#' |
|
| 12 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 13 |
#' Matrices and other inputs are auto-converted. |
|
| 14 |
#' @param title Optional plot title. |
|
| 15 |
#' @param title_size Title font size. |
|
| 16 |
#' @param margins Plot margins as c(bottom, left, top, right). |
|
| 17 |
#' @param layout_margin Margin around the network layout (proportion of viewport). Default 0.15. |
|
| 18 |
#' @param newpage Logical. Start a new graphics page? Default TRUE. |
|
| 19 |
#' @param layout Layout algorithm. Built-in: "circle", "spring", "groups", "grid", |
|
| 20 |
#' "random", "star", "bipartite". igraph (2-letter): "kk" (Kamada-Kawai), |
|
| 21 |
#' "fr" (Fruchterman-Reingold), "drl", "mds", "ni" (nicely), "tr" (tree), etc. |
|
| 22 |
#' Can also pass a coordinate matrix or igraph layout function directly. |
|
| 23 |
#' @param theme Theme name: "classic", "dark", "minimal", etc. |
|
| 24 |
#' @param seed Random seed for deterministic layouts. Default 42. Set NULL for random. |
|
| 25 |
#' @param labels Node labels. Can be a character vector to set custom labels. |
|
| 26 |
#' @param weight_digits Number of decimal places to round edge weights to before |
|
| 27 |
#' plotting. Edges that round to zero are automatically removed. Default 2. |
|
| 28 |
#' Set NULL to disable rounding. |
|
| 29 |
#' @param threshold Minimum absolute edge weight to display. Edges with |
|
| 30 |
#' abs(weight) < threshold are hidden. Similar to qgraph's threshold. |
|
| 31 |
#' @param maximum Maximum edge weight for width scaling. Weights above this |
|
| 32 |
#' are capped. Similar to qgraph's maximum parameter. |
|
| 33 |
#' |
|
| 34 |
#' @param node_size Node size. |
|
| 35 |
#' @param node_shape Node shape: "circle", "square", "triangle", "diamond", |
|
| 36 |
#' "ellipse", "heart", "star", "pie", "donut", "cross". |
|
| 37 |
#' @param node_fill Node fill color. |
|
| 38 |
#' @param node_border_color Node border color. |
|
| 39 |
#' @param node_border_width Node border width. |
|
| 40 |
#' @param node_alpha Node transparency (0-1). |
|
| 41 |
#' @param label_size Node label text size. |
|
| 42 |
#' @param label_color Node label text color. |
|
| 43 |
#' @param label_position Label position: "center", "above", "below", "left", "right". |
|
| 44 |
#' @param show_labels Logical. Show node labels? |
|
| 45 |
#' @param pie_values For pie/donut/donut_pie nodes: list or matrix of values for segments. |
|
| 46 |
#' For donut with single value (0-1), shows that proportion filled. |
|
| 47 |
#' @param pie_colors For pie/donut/donut_pie nodes: colors for pie segments. |
|
| 48 |
#' @param pie_border_width Border width for pie chart segments. |
|
| 49 |
#' @param donut_values For donut_pie nodes: vector of values (0-1) for outer ring proportion. |
|
| 50 |
#' @param donut_border_width Border width for donut ring. |
|
| 51 |
#' @param donut_inner_ratio For donut nodes: inner radius ratio (0-1). Default 0.5. |
|
| 52 |
#' @param donut_bg_color For donut nodes: background color for unfilled portion. |
|
| 53 |
#' @param donut_show_value For donut nodes: show value in center? Default FALSE. |
|
| 54 |
#' @param donut_value_size For donut nodes: font size for center value. |
|
| 55 |
#' @param donut_value_color For donut nodes: color for center value text. |
|
| 56 |
#' @param donut_fill Numeric value (0-1) for donut fill proportion. This is the |
|
| 57 |
#' simplified API for creating donut charts. Can be a single value or vector per node. |
|
| 58 |
#' @param donut_color Fill color(s) for the donut ring. Simplified API: |
|
| 59 |
#' single color for fill, or c(fill, background) for both. |
|
| 60 |
#' @param donut_colors Deprecated. Use donut_color instead. |
|
| 61 |
#' @param donut_shape Base shape for donut: "circle", "square", "hexagon", "triangle", |
|
| 62 |
#' "diamond", "pentagon". Default inherits from node_shape. |
|
| 63 |
#' @param donut_value_fontface Font face for donut center value: "plain", "bold", |
|
| 64 |
#' "italic", "bold.italic". Default "bold". |
|
| 65 |
#' @param donut_value_fontfamily Font family for donut center value. Default "sans". |
|
| 66 |
#' @param donut_value_digits Decimal places for donut center value. Default 2. |
|
| 67 |
#' @param donut_value_prefix Text before donut center value (e.g., "$"). Default "". |
|
| 68 |
#' @param donut_value_suffix Text after donut center value (e.g., "%"). Default "". |
|
| 69 |
#' @param donut2_values List of values for inner donut ring (for double donut). |
|
| 70 |
#' @param donut2_colors List of color vectors for inner donut ring segments. |
|
| 71 |
#' @param donut2_inner_ratio Inner radius ratio for inner donut ring. Default 0.4. |
|
| 72 |
#' |
|
| 73 |
#' @param edge_width Edge width. If NULL, scales by weight using edge_size and edge_width_range. |
|
| 74 |
#' @param edge_size Base edge size for weight scaling. NULL (default) uses adaptive sizing |
|
| 75 |
#' based on network size: `15 * exp(-n_nodes/90) + 1`. Larger values = thicker edges. |
|
| 76 |
#' @param esize Deprecated. Use `edge_size` instead. |
|
| 77 |
#' @param edge_width_range Output width range as c(min, max) for weight-based scaling. |
|
| 78 |
#' Default c(0.5, 4). Edges are scaled to fit within this range. |
|
| 79 |
#' @param edge_scale_mode Scaling mode for edge weights: "linear" (default), |
|
| 80 |
#' "log" (for wide weight ranges), "sqrt" (moderate compression), |
|
| 81 |
#' or "rank" (equal visual spacing). |
|
| 82 |
#' @param edge_cutoff Two-tier cutoff for edge width scaling. NULL (default) = auto 75th percentile. |
|
| 83 |
#' 0 = disabled. Positive number = manual threshold. |
|
| 84 |
#' @param cut Deprecated. Use `edge_cutoff` instead. |
|
| 85 |
#' @param edge_width_scale Scale factor for edge widths. Values > 1 make edges thicker. |
|
| 86 |
#' @param edge_color Edge color. |
|
| 87 |
#' @param edge_alpha Edge transparency (0-1). |
|
| 88 |
#' @param edge_style Line style: "solid", "dashed", "dotted". |
|
| 89 |
#' @param curvature Edge curvature amount. |
|
| 90 |
#' @param arrow_size Size of arrow heads. |
|
| 91 |
#' @param show_arrows Logical. Show arrows? |
|
| 92 |
#' @param edge_positive_color Color for positive edge weights. |
|
| 93 |
#' @param positive_color Deprecated. Use `edge_positive_color` instead. |
|
| 94 |
#' @param edge_negative_color Color for negative edge weights. |
|
| 95 |
#' @param negative_color Deprecated. Use `edge_negative_color` instead. |
|
| 96 |
#' @param edge_duplicates How to handle duplicate edges in undirected networks. |
|
| 97 |
#' NULL (default) = stop with error listing duplicates. Options: "sum", "mean", |
|
| 98 |
#' "first", "max", "min", or a custom aggregation function. |
|
| 99 |
#' @param edge_labels Edge labels. Can be TRUE to show weights, or a vector. |
|
| 100 |
#' @param edge_label_size Edge label text size. |
|
| 101 |
#' @param edge_label_color Edge label text color. |
|
| 102 |
#' @param edge_label_position Position along edge (0 = source, 0.5 = middle, 1 = target). |
|
| 103 |
#' @param edge_label_offset Perpendicular offset from edge line. |
|
| 104 |
#' @param edge_label_bg Background color for edge labels (default "white"). Set to NA for transparent. |
|
| 105 |
#' @param edge_label_fontface Font face: "plain", "bold", "italic", "bold.italic". |
|
| 106 |
#' @param edge_label_border Border style: NULL, "rect", "rounded", "circle". |
|
| 107 |
#' @param edge_label_border_color Border color for label border. |
|
| 108 |
#' @param edge_label_underline Logical. Underline the label text? |
|
| 109 |
#' @param bidirectional Logical. Show arrows at both ends of edges? |
|
| 110 |
#' @param loop_rotation Angle in radians for self-loop direction (default: pi/2 = top). |
|
| 111 |
#' @param curve_shape Spline tension for curved edges (-1 to 1, default: 0). |
|
| 112 |
#' @param curve_pivot Pivot position along edge for curve control point (0-1, default: 0.5). |
|
| 113 |
#' @param curves Curve mode: TRUE (default) = single edges straight, reciprocal edges |
|
| 114 |
#' curve as ellipse (two opposing curves); FALSE = all straight; "force" = all curved. |
|
| 115 |
#' @param node_names Alternative names for legend (separate from display labels). |
|
| 116 |
#' @param legend Logical. Show legend? |
|
| 117 |
#' @param legend_position Legend position: "topright", "topleft", "bottomright", "bottomleft". |
|
| 118 |
#' @param scaling Scaling mode: "default" for qgraph-matched scaling where node_size=6 |
|
| 119 |
#' looks similar to qgraph vsize=6, or "legacy" to preserve pre-v2.0 behavior. |
|
| 120 |
#' |
|
| 121 |
#' @details |
|
| 122 |
#' ## soplot vs splot |
|
| 123 |
#' \code{soplot()} uses grid graphics while \code{splot()} uses base R graphics.
|
|
| 124 |
#' Both accept the same parameters and produce visually similar output. Choose based on: |
|
| 125 |
#' \itemize{
|
|
| 126 |
#' \item \strong{soplot}: Better for integration with ggplot2, combining plots,
|
|
| 127 |
#' and publication-quality vector graphics. |
|
| 128 |
#' \item \strong{splot}: Better for large networks (faster rendering), interactive
|
|
| 129 |
#' exploration, and traditional R workflows. |
|
| 130 |
#' } |
|
| 131 |
#' |
|
| 132 |
#' ## Edge Curve Behavior |
|
| 133 |
#' Edge curving is controlled by the \code{curves} and \code{curvature} parameters:
|
|
| 134 |
#' \describe{
|
|
| 135 |
#' \item{\strong{curves = FALSE}}{All edges are straight lines.}
|
|
| 136 |
#' \item{\strong{curves = TRUE}}{(Default) Reciprocal edge pairs (A\code{->}B and
|
|
| 137 |
#' B\code{->}A) curve in opposite directions to form a visual ellipse. Single
|
|
| 138 |
#' edges remain straight.} |
|
| 139 |
#' \item{\strong{curves = "force"}}{All edges curve inward toward the network center.}
|
|
| 140 |
#' } |
|
| 141 |
#' |
|
| 142 |
#' ## Weight Scaling Modes (edge_scale_mode) |
|
| 143 |
#' Controls how edge weights map to visual widths: |
|
| 144 |
#' \describe{
|
|
| 145 |
#' \item{\strong{linear}}{Width proportional to weight. Best for similar-magnitude weights.}
|
|
| 146 |
#' \item{\strong{log}}{Logarithmic scaling. Best for weights spanning orders of magnitude.}
|
|
| 147 |
#' \item{\strong{sqrt}}{Square root scaling. Moderate compression for skewed data.}
|
|
| 148 |
#' \item{\strong{rank}}{Rank-based scaling. Equal visual spacing regardless of values.}
|
|
| 149 |
#' } |
|
| 150 |
#' |
|
| 151 |
#' ## Donut Visualization |
|
| 152 |
#' The donut system visualizes proportions (0-1) as filled rings around nodes: |
|
| 153 |
#' \describe{
|
|
| 154 |
#' \item{\strong{donut_fill}}{Proportion filled (0-1). Can be scalar or per-node vector.}
|
|
| 155 |
#' \item{\strong{donut_color}}{Fill color. Single color, c(fill, bg), or per-node vector.}
|
|
| 156 |
#' \item{\strong{donut_shape}}{Base shape: "circle", "square", "hexagon", etc.}
|
|
| 157 |
#' \item{\strong{donut_show_value}}{Show numeric value in center.}
|
|
| 158 |
#' } |
|
| 159 |
#' |
|
| 160 |
#' @return Invisible NULL. Called for side effect of drawing. |
|
| 161 |
#' |
|
| 162 |
#' @seealso |
|
| 163 |
#' \code{\link{splot}} for base R graphics rendering (alternative engine),
|
|
| 164 |
#' \code{\link{cograph}} for creating network objects,
|
|
| 165 |
#' \code{\link{sn_nodes}} for node customization,
|
|
| 166 |
#' \code{\link{sn_edges}} for edge customization,
|
|
| 167 |
#' \code{\link{sn_layout}} for layout algorithms,
|
|
| 168 |
#' \code{\link{sn_theme}} for visual themes,
|
|
| 169 |
#' \code{\link{from_qgraph}} and \code{\link{from_tna}} for converting external objects
|
|
| 170 |
#' @export |
|
| 171 |
#' |
|
| 172 |
#' @examples |
|
| 173 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 174 |
#' # With cograph() |
|
| 175 |
#' cograph(adj) |> soplot() |
|
| 176 |
#' |
|
| 177 |
#' # Direct matrix input with all options |
|
| 178 |
#' adj |> soplot( |
|
| 179 |
#' layout = "circle", |
|
| 180 |
#' node_fill = "steelblue", |
|
| 181 |
#' node_size = 0.08, |
|
| 182 |
#' edge_width = 2 |
|
| 183 |
#' ) |
|
| 184 |
soplot <- function(network, title = NULL, title_size = 14, |
|
| 185 |
margins = c(0.05, 0.05, 0.1, 0.05), |
|
| 186 |
layout_margin = 0.15, |
|
| 187 |
newpage = TRUE, |
|
| 188 |
# Layout and theme |
|
| 189 |
layout = NULL, |
|
| 190 |
theme = NULL, |
|
| 191 |
seed = 42, |
|
| 192 |
# Node labels |
|
| 193 |
labels = NULL, |
|
| 194 |
# Edge filtering/scaling |
|
| 195 |
threshold = NULL, |
|
| 196 |
maximum = NULL, |
|
| 197 |
# Node aesthetics |
|
| 198 |
node_size = NULL, |
|
| 199 |
node_shape = NULL, |
|
| 200 |
node_fill = NULL, |
|
| 201 |
node_border_color = NULL, |
|
| 202 |
node_border_width = NULL, |
|
| 203 |
node_alpha = NULL, |
|
| 204 |
# Node labels |
|
| 205 |
label_size = NULL, |
|
| 206 |
label_color = NULL, |
|
| 207 |
label_position = NULL, |
|
| 208 |
show_labels = NULL, |
|
| 209 |
# Pie/donut chart nodes |
|
| 210 |
pie_values = NULL, |
|
| 211 |
pie_colors = NULL, |
|
| 212 |
pie_border_width = NULL, |
|
| 213 |
donut_values = NULL, |
|
| 214 |
donut_border_width = NULL, |
|
| 215 |
donut_inner_ratio = NULL, |
|
| 216 |
donut_bg_color = NULL, |
|
| 217 |
donut_show_value = NULL, |
|
| 218 |
donut_value_size = NULL, |
|
| 219 |
donut_value_color = NULL, |
|
| 220 |
# NEW donut parameters for feature parity with splot |
|
| 221 |
donut_fill = NULL, |
|
| 222 |
donut_color = NULL, |
|
| 223 |
donut_colors = NULL, # Deprecated: use donut_color |
|
| 224 |
donut_shape = "circle", |
|
| 225 |
donut_value_fontface = "bold", |
|
| 226 |
donut_value_fontfamily = "sans", |
|
| 227 |
donut_value_digits = 2, |
|
| 228 |
donut_value_prefix = "", |
|
| 229 |
donut_value_suffix = "", |
|
| 230 |
donut2_values = NULL, |
|
| 231 |
donut2_colors = NULL, |
|
| 232 |
donut2_inner_ratio = 0.4, |
|
| 233 |
# Edge aesthetics |
|
| 234 |
edge_width = NULL, |
|
| 235 |
edge_size = NULL, |
|
| 236 |
esize = NULL, # Deprecated: use edge_size |
|
| 237 |
edge_width_range = NULL, |
|
| 238 |
edge_scale_mode = "linear", |
|
| 239 |
edge_cutoff = NULL, |
|
| 240 |
cut = NULL, # Deprecated: use edge_cutoff |
|
| 241 |
edge_width_scale = NULL, |
|
| 242 |
edge_color = NULL, |
|
| 243 |
edge_alpha = NULL, |
|
| 244 |
edge_style = NULL, |
|
| 245 |
curvature = NULL, |
|
| 246 |
arrow_size = NULL, |
|
| 247 |
show_arrows = NULL, |
|
| 248 |
edge_positive_color = NULL, |
|
| 249 |
positive_color = NULL, # Deprecated: use edge_positive_color |
|
| 250 |
edge_negative_color = NULL, |
|
| 251 |
negative_color = NULL, # Deprecated: use edge_negative_color |
|
| 252 |
edge_duplicates = NULL, |
|
| 253 |
# Edge labels |
|
| 254 |
edge_labels = NULL, |
|
| 255 |
edge_label_size = NULL, |
|
| 256 |
edge_label_color = NULL, |
|
| 257 |
edge_label_position = NULL, |
|
| 258 |
edge_label_offset = NULL, |
|
| 259 |
edge_label_bg = NULL, |
|
| 260 |
edge_label_fontface = NULL, |
|
| 261 |
edge_label_border = NULL, |
|
| 262 |
edge_label_border_color = NULL, |
|
| 263 |
edge_label_underline = NULL, |
|
| 264 |
# Advanced edge options |
|
| 265 |
bidirectional = NULL, |
|
| 266 |
loop_rotation = NULL, |
|
| 267 |
curve_shape = NULL, |
|
| 268 |
curve_pivot = NULL, |
|
| 269 |
curves = NULL, |
|
| 270 |
# Legend options |
|
| 271 |
node_names = NULL, |
|
| 272 |
legend = FALSE, |
|
| 273 |
legend_position = "topright", |
|
| 274 |
# Scaling mode |
|
| 275 |
scaling = "default", |
|
| 276 |
weight_digits = 2) {
|
|
| 277 | ||
| 278 | ||
| 279 |
# Handle tna objects directly |
|
| 280 | 509x |
if (inherits(network, "tna")) {
|
| 281 | 2x |
tna_params <- from_tna(network, engine = "soplot", plot = FALSE) |
| 282 | 2x |
call_args <- tna_params |
| 283 |
# from_tna returns $x; soplot expects $network |
|
| 284 | 2x |
call_args$network <- call_args$x |
| 285 | 2x |
call_args$x <- NULL |
| 286 | 2x |
call_args$layout <- layout |
| 287 | 2x |
call_args$seed <- seed |
| 288 | 2x |
call_args$theme <- theme |
| 289 |
# Apply user overrides |
|
| 290 | 2x |
user_args <- as.list(match.call(expand.dots = FALSE))[-1] |
| 291 | 2x |
user_args$network <- NULL |
| 292 | 2x |
for (nm in names(user_args)) {
|
| 293 | 1x |
val <- eval(user_args[[nm]], envir = parent.frame()) |
| 294 | 1x |
if (!is.null(val)) call_args[[nm]] <- val |
| 295 |
} |
|
| 296 |
# Filter to accepted soplot params |
|
| 297 | 2x |
accepted <- names(formals(soplot)) |
| 298 | 2x |
call_args <- call_args[intersect(names(call_args), accepted)] |
| 299 | 2x |
return(do.call(soplot, call_args)) |
| 300 |
} |
|
| 301 | ||
| 302 |
# ============================================ |
|
| 303 |
# HANDLE DEPRECATED PARAMETERS |
|
| 304 |
# ============================================ |
|
| 305 |
# Detect which arguments were explicitly provided by the user |
|
| 306 | 507x |
explicit_args <- names(match.call()) |
| 307 | ||
| 308 |
# For params with NULL defaults, simple check works |
|
| 309 | 507x |
edge_size <- handle_deprecated_param(edge_size, esize, "edge_size", "esize") |
| 310 | 507x |
edge_cutoff <- handle_deprecated_param(edge_cutoff, cut, "edge_cutoff", "cut") |
| 311 | ||
| 312 |
# For params with non-NULL defaults, use new_val_was_set to check if user explicitly set them |
|
| 313 | 507x |
edge_positive_color <- handle_deprecated_param( |
| 314 | 507x |
edge_positive_color, positive_color, |
| 315 | 507x |
"edge_positive_color", "positive_color", |
| 316 | 507x |
new_val_was_set = "edge_positive_color" %in% explicit_args |
| 317 |
) |
|
| 318 | 507x |
edge_negative_color <- handle_deprecated_param( |
| 319 | 507x |
edge_negative_color, negative_color, |
| 320 | 507x |
"edge_negative_color", "negative_color", |
| 321 | 507x |
new_val_was_set = "edge_negative_color" %in% explicit_args |
| 322 |
) |
|
| 323 | ||
| 324 |
# Set seed for deterministic layouts |
|
| 325 | 507x |
if (!is.null(seed)) {
|
| 326 | 507x |
set.seed(seed) |
| 327 |
} |
|
| 328 | ||
| 329 |
# Get scale constants for current scaling mode |
|
| 330 | 507x |
scale <- get_scale_constants(scaling) |
| 331 | ||
| 332 |
# Two-letter igraph layout codes |
|
| 333 | 507x |
igraph_codes <- c("kk", "fr", "drl", "mds", "go", "tr", "st", "gr", "rd", "ni", "ci", "lgl", "sp")
|
| 334 | ||
| 335 |
# Determine effective layout |
|
| 336 | 507x |
effective_layout <- layout %||% "spring" |
| 337 | ||
| 338 |
# Round matrix weights to filter near-zero edges globally |
|
| 339 | 507x |
if (is.matrix(network) && !is.null(weight_digits)) {
|
| 340 | 418x |
network <- round(network, weight_digits) |
| 341 |
} |
|
| 342 | ||
| 343 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 344 | 507x |
network <- ensure_cograph_network(network, layout = effective_layout, seed = seed) |
| 345 | ||
| 346 |
# Check for duplicate edges in undirected networks |
|
| 347 | 506x |
net <- network$network |
| 348 | 506x |
directed <- net$is_directed |
| 349 | 506x |
edges <- net$get_edges() |
| 350 | 506x |
if (!directed && !is.null(edges) && nrow(edges) > 0) {
|
| 351 | 444x |
dup_check <- detect_duplicate_edges(edges) |
| 352 | 444x |
if (dup_check$has_duplicates) {
|
| 353 | 2x |
if (is.null(edge_duplicates)) {
|
| 354 |
# Build error message |
|
| 355 | 1x |
dup_msg <- vapply(dup_check$info, function(d) {
|
| 356 | 1x |
sprintf(" - Nodes %d-%d: %d edges (weights: %s)",
|
| 357 | 1x |
d$nodes[1], d$nodes[2], d$count, |
| 358 | 1x |
paste(round(d$weights, 2), collapse = ", ")) |
| 359 | 1x |
}, character(1)) |
| 360 | 1x |
stop("Found ", length(dup_check$info), " duplicate edge pair(s) in undirected network:\n",
|
| 361 | 1x |
paste(dup_msg, collapse = "\n"), "\n\n", |
| 362 | 1x |
"Specify how to handle with edge_duplicates parameter:\n", |
| 363 | 1x |
" edge_duplicates = \"sum\" # Sum weights\n", |
| 364 | 1x |
" edge_duplicates = \"mean\" # Average weights\n", |
| 365 | 1x |
" edge_duplicates = \"first\" # Keep first edge\n", |
| 366 | 1x |
" edge_duplicates = \"max\" # Keep max weight\n", |
| 367 | 1x |
" edge_duplicates = \"min\" # Keep min weight\n", |
| 368 | 1x |
call. = FALSE) |
| 369 |
} |
|
| 370 | 1x |
edges <- aggregate_duplicate_edges(edges, edge_duplicates) |
| 371 | 1x |
net$set_edges(edges) |
| 372 |
} |
|
| 373 |
} |
|
| 374 | ||
| 375 |
# Apply custom node labels if provided |
|
| 376 | 505x |
if (!is.null(labels)) {
|
| 377 | 9x |
net <- network$network |
| 378 | 9x |
nodes_df <- net$get_nodes() |
| 379 | 9x |
if (length(labels) != nrow(nodes_df)) {
|
| 380 | 1x |
stop("labels length (", length(labels), ") must match number of nodes (",
|
| 381 | 1x |
nrow(nodes_df), ")", call. = FALSE) |
| 382 |
} |
|
| 383 | 8x |
nodes_df$label <- labels |
| 384 | 8x |
net$set_nodes(nodes_df) |
| 385 |
} |
|
| 386 | ||
| 387 |
# Apply threshold - filter out weak edges |
|
| 388 | 504x |
if (!is.null(threshold)) {
|
| 389 | 4x |
net <- network$network |
| 390 | 4x |
edges_df <- net$get_edges() |
| 391 | 4x |
if (!is.null(edges_df) && nrow(edges_df) > 0 && !is.null(edges_df$weight)) {
|
| 392 | 4x |
keep <- abs(edges_df$weight) >= threshold |
| 393 | 4x |
edges_df <- edges_df[keep, , drop = FALSE] |
| 394 | 4x |
net$set_edges(edges_df) |
| 395 |
} |
|
| 396 |
} |
|
| 397 | ||
| 398 |
# Apply layout if specified |
|
| 399 | 504x |
if (!is.null(layout)) {
|
| 400 | 163x |
network <- sn_layout(network, layout) |
| 401 |
} |
|
| 402 | ||
| 403 |
# Apply theme if specified |
|
| 404 | 504x |
if (!is.null(theme)) {
|
| 405 | 26x |
network <- sn_theme(network, theme) |
| 406 |
} |
|
| 407 | ||
| 408 |
# ============================================ |
|
| 409 |
# DONUT PROCESSING (for feature parity with splot) |
|
| 410 |
# ============================================ |
|
| 411 | ||
| 412 |
# Get node count for processing |
|
| 413 | 504x |
n_nodes <- nrow(network$network$get_nodes()) |
| 414 | ||
| 415 |
# Get shapes for processing |
|
| 416 | 504x |
shapes <- recycle_to_length(node_shape %||% "circle", n_nodes) |
| 417 | ||
| 418 |
# Auto-enable donut fill when node_shape is "donut" but no fill specified |
|
| 419 | 504x |
if (is.null(donut_fill) && is.null(donut_values)) {
|
| 420 | 468x |
if (any(shapes == "donut")) {
|
| 421 |
# Create per-node fill: 1.0 for donut nodes, NA for others |
|
| 422 | 5x |
donut_fill <- ifelse(shapes == "donut", 1.0, NA) |
| 423 |
} |
|
| 424 |
} |
|
| 425 | ||
| 426 |
# Handle donut_fill: convert to list format if provided |
|
| 427 |
# donut_fill takes precedence over donut_values for the new simplified API |
|
| 428 | 504x |
effective_donut_values <- donut_values |
| 429 | 504x |
if (!is.null(donut_fill)) {
|
| 430 |
# Convert donut_fill to list format for internal use |
|
| 431 | 30x |
if (!is.list(donut_fill)) {
|
| 432 | 29x |
fill_vec <- recycle_to_length(donut_fill, n_nodes) |
| 433 | 29x |
effective_donut_values <- as.list(fill_vec) |
| 434 |
} else {
|
|
| 435 | 1x |
effective_donut_values <- donut_fill |
| 436 |
} |
|
| 437 |
} |
|
| 438 | ||
| 439 |
# Handle donut_color (new simplified API) and donut_colors (deprecated) |
|
| 440 |
# Priority: donut_color > donut_colors |
|
| 441 | 504x |
effective_donut_colors <- NULL |
| 442 | 504x |
effective_bg_color <- donut_bg_color |
| 443 | ||
| 444 | 504x |
if (!is.null(donut_color)) {
|
| 445 | 8x |
if (is.list(donut_color) && length(donut_color) == 2 * n_nodes) {
|
| 446 |
# List with 2×n_nodes: per-node (fill, bg) pairs - extract odd indices for fill |
|
| 447 | 1x |
effective_donut_colors <- as.list(donut_color[seq(1, 2 * n_nodes, by = 2)]) |
| 448 | 7x |
} else if (length(donut_color) == 2) {
|
| 449 |
# Two colors: fill + background for ALL nodes |
|
| 450 | 2x |
effective_donut_colors <- as.list(rep(donut_color[1], n_nodes)) |
| 451 | 2x |
effective_bg_color <- donut_color[2] |
| 452 | 5x |
} else if (length(donut_color) == 1) {
|
| 453 |
# Single color: fill for all nodes |
|
| 454 | 4x |
effective_donut_colors <- as.list(rep(donut_color, n_nodes)) |
| 455 |
} else {
|
|
| 456 |
# Multiple colors (not 2): treat as per-node fill colors |
|
| 457 | 1x |
cols <- recycle_to_length(donut_color, n_nodes) |
| 458 | 1x |
effective_donut_colors <- as.list(cols) |
| 459 |
} |
|
| 460 | 496x |
} else if (!is.null(donut_colors)) {
|
| 461 |
# Deprecated: use old donut_colors parameter |
|
| 462 | 3x |
effective_donut_colors <- donut_colors |
| 463 | 493x |
} else if (any(shapes == "donut") || !is.null(effective_donut_values)) {
|
| 464 |
# Default fill color: light gray when donuts are being used |
|
| 465 | 30x |
effective_donut_colors <- as.list(rep("maroon", n_nodes))
|
| 466 |
} |
|
| 467 | ||
| 468 |
# Determine effective donut shapes - inherit from node_shape by default |
|
| 469 |
# If donut_shape is NULL or "circle" (default), inherit from node_shape |
|
| 470 |
# Otherwise, use the explicitly set donut_shape |
|
| 471 | 504x |
valid_donut_base_shapes <- c("circle", "square", "hexagon", "triangle", "diamond", "pentagon")
|
| 472 | 504x |
if (is.null(donut_shape) || identical(donut_shape, "circle")) {
|
| 473 |
# Inherit from node_shape, but only if it's a valid donut base shape |
|
| 474 |
# donut, donut_pie, double_donut_pie and custom SVG shapes default to "circle" |
|
| 475 | 491x |
special_donut_shapes <- c("donut", "donut_pie", "double_donut_pie")
|
| 476 | 491x |
effective_donut_shapes <- ifelse( |
| 477 | 491x |
shapes %in% valid_donut_base_shapes, |
| 478 | 491x |
shapes, |
| 479 | 491x |
"circle" # Default for SVG shapes and special shapes |
| 480 |
) |
|
| 481 |
} else {
|
|
| 482 |
# User explicitly set donut_shape - vectorize and use it |
|
| 483 | 13x |
effective_donut_shapes <- recycle_to_length(donut_shape, n_nodes) |
| 484 |
} |
|
| 485 | ||
| 486 |
# Convert node_size using scale constants (qgraph-style to NPC) |
|
| 487 |
# If node_size is provided, convert it; otherwise let render_nodes_grid use default |
|
| 488 | 504x |
effective_node_size <- if (!is.null(node_size)) {
|
| 489 |
# Convert from qgraph-style units to NPC coordinates |
|
| 490 | 11x |
node_size * scale$soplot_node_factor |
| 491 |
} else {
|
|
| 492 |
# Use default from scale constants, converted to NPC |
|
| 493 | 493x |
scale$node_default * scale$soplot_node_factor |
| 494 |
} |
|
| 495 | ||
| 496 |
# Apply node aesthetics if any specified |
|
| 497 | 504x |
node_aes <- list( |
| 498 | 504x |
size = effective_node_size, |
| 499 | 504x |
shape = node_shape, |
| 500 | 504x |
fill = node_fill, |
| 501 | 504x |
border_color = node_border_color, |
| 502 | 504x |
border_width = node_border_width, |
| 503 | 504x |
alpha = node_alpha, |
| 504 | 504x |
label_size = label_size, |
| 505 | 504x |
label_color = label_color, |
| 506 | 504x |
label_position = label_position, |
| 507 | 504x |
show_labels = show_labels, |
| 508 | 504x |
pie_values = pie_values, |
| 509 | 504x |
pie_colors = pie_colors, |
| 510 | 504x |
pie_border_width = pie_border_width, |
| 511 |
# Use processed donut values for feature parity with splot |
|
| 512 | 504x |
donut_values = effective_donut_values, |
| 513 | 504x |
donut_colors = effective_donut_colors, |
| 514 | 504x |
donut_border_width = donut_border_width, |
| 515 | 504x |
donut_inner_ratio = donut_inner_ratio, |
| 516 | 504x |
donut_bg_color = effective_bg_color, |
| 517 | 504x |
donut_shape = effective_donut_shapes, |
| 518 | 504x |
donut_show_value = donut_show_value, |
| 519 | 504x |
donut_value_size = donut_value_size, |
| 520 | 504x |
donut_value_color = donut_value_color, |
| 521 |
# NEW donut value formatting parameters |
|
| 522 | 504x |
donut_value_fontface = donut_value_fontface, |
| 523 | 504x |
donut_value_fontfamily = donut_value_fontfamily, |
| 524 | 504x |
donut_value_digits = donut_value_digits, |
| 525 | 504x |
donut_value_prefix = donut_value_prefix, |
| 526 | 504x |
donut_value_suffix = donut_value_suffix, |
| 527 |
# Double donut parameters |
|
| 528 | 504x |
donut2_values = donut2_values, |
| 529 | 504x |
donut2_colors = donut2_colors, |
| 530 | 504x |
donut2_inner_ratio = donut2_inner_ratio, |
| 531 | 504x |
node_names = node_names |
| 532 |
) |
|
| 533 | 504x |
node_aes <- node_aes[!sapply(node_aes, is.null)] |
| 534 | 504x |
if (length(node_aes) > 0) {
|
| 535 | 504x |
network <- do.call(sn_nodes, c(list(network = network), node_aes)) |
| 536 |
} |
|
| 537 | ||
| 538 |
# Convert arrow_size using scale constants for consistency with splot |
|
| 539 | 504x |
effective_arrow_size <- if (!is.null(arrow_size)) {
|
| 540 | 10x |
arrow_size * scale$arrow_factor |
| 541 |
} else {
|
|
| 542 | 494x |
NULL # Let render_edges_grid use default |
| 543 |
} |
|
| 544 | ||
| 545 |
# Apply edge aesthetics if any specified |
|
| 546 | 504x |
edge_aes <- list( |
| 547 | 504x |
width = edge_width, |
| 548 | 504x |
edge_size = edge_size, |
| 549 | 504x |
edge_width_range = edge_width_range, |
| 550 | 504x |
edge_scale_mode = edge_scale_mode, |
| 551 | 504x |
edge_cutoff = edge_cutoff, |
| 552 | 504x |
width_scale = edge_width_scale, |
| 553 | 504x |
color = edge_color, |
| 554 | 504x |
alpha = edge_alpha, |
| 555 | 504x |
style = edge_style, |
| 556 | 504x |
curvature = curvature, |
| 557 | 504x |
arrow_size = effective_arrow_size, |
| 558 | 504x |
show_arrows = show_arrows, |
| 559 | 504x |
edge_positive_color = edge_positive_color, |
| 560 | 504x |
edge_negative_color = edge_negative_color, |
| 561 | 504x |
maximum = maximum, |
| 562 | 504x |
labels = edge_labels, |
| 563 | 504x |
label_size = edge_label_size, |
| 564 | 504x |
label_color = edge_label_color, |
| 565 | 504x |
label_position = edge_label_position, |
| 566 | 504x |
label_offset = edge_label_offset, |
| 567 | 504x |
label_bg = edge_label_bg, |
| 568 | 504x |
label_fontface = edge_label_fontface, |
| 569 | 504x |
label_border = edge_label_border, |
| 570 | 504x |
label_border_color = edge_label_border_color, |
| 571 | 504x |
label_underline = edge_label_underline, |
| 572 | 504x |
bidirectional = bidirectional, |
| 573 | 504x |
loop_rotation = loop_rotation, |
| 574 | 504x |
curve_shape = curve_shape, |
| 575 | 504x |
curve_pivot = curve_pivot, |
| 576 | 504x |
curves = curves |
| 577 |
) |
|
| 578 | 504x |
edge_aes <- edge_aes[!sapply(edge_aes, is.null)] |
| 579 | 504x |
if (length(edge_aes) > 0) {
|
| 580 | 504x |
network <- do.call(sn_edges, c(list(network = network), edge_aes)) |
| 581 |
} |
|
| 582 | ||
| 583 | 504x |
net <- network$network |
| 584 | 504x |
th <- net$get_theme() |
| 585 | ||
| 586 |
# Rescale layout coordinates to [0.1, 0.9] range (same as splot) |
|
| 587 |
# This ensures consistent rendering between soplot and splot |
|
| 588 | 504x |
nodes <- net$get_nodes() |
| 589 | 504x |
if (!is.null(nodes) && nrow(nodes) > 0 && !is.null(nodes$x) && !is.null(nodes$y)) {
|
| 590 | 504x |
x <- nodes$x |
| 591 | 504x |
y <- nodes$y |
| 592 | ||
| 593 |
# Handle single node case |
|
| 594 | 504x |
if (nrow(nodes) == 1) {
|
| 595 | 5x |
nodes$x <- 0.5 |
| 596 | 5x |
nodes$y <- 0.5 |
| 597 |
} else {
|
|
| 598 |
# Rescale to [0.1, 0.9] range |
|
| 599 | 499x |
x_range <- range(x, na.rm = TRUE) |
| 600 | 499x |
y_range <- range(y, na.rm = TRUE) |
| 601 | ||
| 602 |
# Uniform scaling to preserve aspect ratio |
|
| 603 | 499x |
margin <- layout_margin |
| 604 | 499x |
max_range <- max(diff(x_range), diff(y_range)) |
| 605 | 499x |
if (max_range > 1e-10) {
|
| 606 | 497x |
x_center <- mean(x_range) |
| 607 | 497x |
y_center <- mean(y_range) |
| 608 | 497x |
nodes$x <- 0.5 + (x - x_center) / max_range * (1 - 2 * margin) |
| 609 | 497x |
nodes$y <- 0.5 + (y - y_center) / max_range * (1 - 2 * margin) |
| 610 |
} else {
|
|
| 611 | 2x |
nodes$x <- rep(0.5, nrow(nodes)) |
| 612 | 2x |
nodes$y <- rep(0.5, nrow(nodes)) |
| 613 |
} |
|
| 614 |
} |
|
| 615 | ||
| 616 | 504x |
net$set_nodes(nodes) |
| 617 |
} |
|
| 618 | ||
| 619 | 504x |
if (newpage) {
|
| 620 | 502x |
grid::grid.newpage() |
| 621 |
} |
|
| 622 | ||
| 623 |
# Draw background |
|
| 624 | 504x |
bg_color <- if (!is.null(th)) th$get("background") else "white"
|
| 625 | 503x |
grid::grid.rect(gp = grid::gpar(fill = bg_color, col = NA)) |
| 626 | ||
| 627 |
# Create viewport with margins |
|
| 628 | 503x |
vp <- grid::viewport( |
| 629 | 503x |
x = grid::unit(0.5, "npc"), |
| 630 | 503x |
y = grid::unit(0.5, "npc"), |
| 631 | 503x |
width = grid::unit(1 - margins[2] - margins[4], "npc"), |
| 632 | 503x |
height = grid::unit(1 - margins[1] - margins[3], "npc") |
| 633 |
) |
|
| 634 | 503x |
grid::pushViewport(vp) |
| 635 | ||
| 636 |
# Render edges first (behind nodes) |
|
| 637 | 503x |
edge_grobs <- render_edges_grid(net) |
| 638 | 503x |
grid::grid.draw(edge_grobs) |
| 639 | ||
| 640 |
# Render edge labels |
|
| 641 | 503x |
edge_label_grobs <- render_edge_labels_grid(net) |
| 642 | 503x |
grid::grid.draw(edge_label_grobs) |
| 643 | ||
| 644 |
# Render nodes |
|
| 645 | 503x |
node_grobs <- render_nodes_grid(net) |
| 646 | 503x |
grid::grid.draw(node_grobs) |
| 647 | ||
| 648 |
# Render node labels |
|
| 649 | 503x |
label_grobs <- render_node_labels_grid(net) |
| 650 | 503x |
grid::grid.draw(label_grobs) |
| 651 | ||
| 652 |
# Render legend if requested |
|
| 653 | 501x |
if (isTRUE(legend)) {
|
| 654 | 18x |
legend_grobs <- render_legend_grid(net, position = legend_position) |
| 655 | 18x |
grid::grid.draw(legend_grobs) |
| 656 |
} |
|
| 657 | ||
| 658 | 501x |
grid::popViewport() |
| 659 | ||
| 660 |
# Draw title if provided |
|
| 661 | 501x |
if (!is.null(title)) {
|
| 662 | 8x |
title_col <- if (!is.null(th)) th$get("title_color") else "black"
|
| 663 |
# Position title within the top margin, ensuring it's visible |
|
| 664 |
# Use at least 0.02 from the top edge to prevent clipping |
|
| 665 | 8x |
title_y <- 1 - max(margins[3] / 2, 0.02) |
| 666 | 8x |
grid::grid.text( |
| 667 | 8x |
title, |
| 668 | 8x |
x = grid::unit(0.5, "npc"), |
| 669 | 8x |
y = grid::unit(title_y, "npc"), |
| 670 | 8x |
gp = grid::gpar(fontsize = title_size, col = title_col, fontface = "bold") |
| 671 |
) |
|
| 672 |
} |
|
| 673 | ||
| 674 |
# Store all plot parameters in the network object |
|
| 675 | 501x |
plot_params <- list( |
| 676 | 501x |
title = title, title_size = title_size, margins = margins, |
| 677 | 501x |
layout = effective_layout, theme = theme, seed = seed, scaling = scaling, |
| 678 | 501x |
labels = labels, threshold = threshold, maximum = maximum, |
| 679 | 501x |
node_size = node_size, node_shape = node_shape, node_fill = node_fill, |
| 680 | 501x |
node_border_color = node_border_color, node_border_width = node_border_width, |
| 681 | 501x |
node_alpha = node_alpha, label_size = label_size, label_color = label_color, |
| 682 | 501x |
label_position = label_position, show_labels = show_labels, |
| 683 | 501x |
pie_values = pie_values, pie_colors = pie_colors, pie_border_width = pie_border_width, |
| 684 | 501x |
donut_fill = donut_fill, donut_values = donut_values, |
| 685 | 501x |
donut_color = donut_color, donut_colors = donut_colors, |
| 686 | 501x |
donut_border_width = donut_border_width, |
| 687 | 501x |
donut_inner_ratio = donut_inner_ratio, donut_bg_color = donut_bg_color, |
| 688 | 501x |
donut_shape = donut_shape, |
| 689 | 501x |
donut_show_value = donut_show_value, donut_value_size = donut_value_size, |
| 690 | 501x |
donut_value_color = donut_value_color, |
| 691 | 501x |
donut_value_fontface = donut_value_fontface, |
| 692 | 501x |
donut_value_fontfamily = donut_value_fontfamily, |
| 693 | 501x |
donut_value_digits = donut_value_digits, |
| 694 | 501x |
donut_value_prefix = donut_value_prefix, |
| 695 | 501x |
donut_value_suffix = donut_value_suffix, |
| 696 | 501x |
donut2_values = donut2_values, donut2_colors = donut2_colors, |
| 697 | 501x |
donut2_inner_ratio = donut2_inner_ratio, |
| 698 | 501x |
edge_width = edge_width, edge_size = edge_size, |
| 699 | 501x |
edge_width_range = edge_width_range, edge_scale_mode = edge_scale_mode, |
| 700 | 501x |
edge_cutoff = edge_cutoff, edge_width_scale = edge_width_scale, edge_color = edge_color, |
| 701 | 501x |
edge_alpha = edge_alpha, edge_style = edge_style, |
| 702 | 501x |
curvature = curvature, arrow_size = arrow_size, show_arrows = show_arrows, |
| 703 | 501x |
edge_positive_color = edge_positive_color, edge_negative_color = edge_negative_color, |
| 704 | 501x |
edge_labels = edge_labels, edge_label_size = edge_label_size, |
| 705 | 501x |
edge_label_color = edge_label_color, edge_label_position = edge_label_position, |
| 706 | 501x |
edge_label_offset = edge_label_offset, |
| 707 | 501x |
bidirectional = bidirectional, loop_rotation = loop_rotation, |
| 708 | 501x |
curve_shape = curve_shape, curve_pivot = curve_pivot, |
| 709 | 501x |
node_names = node_names, legend = legend, legend_position = legend_position |
| 710 |
) |
|
| 711 |
# Remove NULL values |
|
| 712 | 501x |
plot_params <- plot_params[!sapply(plot_params, is.null)] |
| 713 | 501x |
net$set_plot_params(plot_params) |
| 714 | ||
| 715 |
# Store layout coordinates |
|
| 716 | 501x |
net$set_layout_info(list( |
| 717 | 501x |
name = effective_layout, |
| 718 | 501x |
seed = seed, |
| 719 | 501x |
coords = net$get_layout() |
| 720 |
)) |
|
| 721 | ||
| 722 |
# Re-create wrapper with updated data |
|
| 723 | 501x |
invisible(as_cograph_network(net)) |
| 724 |
} |
|
| 725 | ||
| 726 |
#' Create Grid Grob Tree |
|
| 727 |
#' |
|
| 728 |
#' Create a complete grid grob tree for the network (without drawing). |
|
| 729 |
#' |
|
| 730 |
#' @param network A cograph_network object. |
|
| 731 |
#' @param title Optional plot title. |
|
| 732 |
#' @return A grid gTree object. |
|
| 733 |
#' @keywords internal |
|
| 734 |
create_grid_grob <- function(network, title = NULL) {
|
|
| 735 | 2x |
if (!inherits(network, "cograph_network")) {
|
| 736 | 1x |
stop("network must be a cograph_network object", call. = FALSE)
|
| 737 |
} |
|
| 738 | ||
| 739 | 1x |
net <- network$network |
| 740 | 1x |
theme <- net$get_theme() |
| 741 | ||
| 742 |
# Background |
|
| 743 | 1x |
bg_color <- if (!is.null(theme)) theme$get("background") else "white"
|
| 744 | 1x |
bg_grob <- grid::rectGrob(gp = grid::gpar(fill = bg_color, col = NA)) |
| 745 | ||
| 746 |
# Edge grobs |
|
| 747 | 1x |
edge_grobs <- render_edges_grid(net) |
| 748 | ||
| 749 |
# Node grobs |
|
| 750 | 1x |
node_grobs <- render_nodes_grid(net) |
| 751 | ||
| 752 |
# Label grobs |
|
| 753 | 1x |
label_grobs <- render_node_labels_grid(net) |
| 754 | ||
| 755 |
# Edge label grobs |
|
| 756 | 1x |
edge_label_grobs <- render_edge_labels_grid(net) |
| 757 | ||
| 758 |
# Combine all |
|
| 759 | 1x |
children <- grid::gList(bg_grob, edge_grobs, edge_label_grobs, |
| 760 | 1x |
node_grobs, label_grobs) |
| 761 | ||
| 762 |
# Add title if provided |
|
| 763 | 1x |
if (!is.null(title)) {
|
| 764 | 1x |
title_col <- if (!is.null(theme)) theme$get("title_color") else "black"
|
| 765 | 1x |
title_grob <- grid::textGrob( |
| 766 | 1x |
title, |
| 767 | 1x |
x = grid::unit(0.5, "npc"), |
| 768 | 1x |
y = grid::unit(0.95, "npc"), |
| 769 | 1x |
gp = grid::gpar(fontsize = 14, col = title_col, fontface = "bold") |
| 770 |
) |
|
| 771 | 1x |
children <- grid::gList(children, title_grob) |
| 772 |
} |
|
| 773 | ||
| 774 | 1x |
grid::gTree(children = children, name = "cograph_plot") |
| 775 |
} |
|
| 776 | ||
| 777 |
#' Render Legend |
|
| 778 |
#' |
|
| 779 |
#' Create grid grobs for the network legend. |
|
| 780 |
#' |
|
| 781 |
#' @param network A CographNetwork object. |
|
| 782 |
#' @param position Legend position: "topright", "topleft", "bottomright", "bottomleft". |
|
| 783 |
#' @return A grid gList of legend grobs. |
|
| 784 |
#' @keywords internal |
|
| 785 |
render_legend_grid <- function(network, position = "topright") {
|
|
| 786 | 22x |
nodes <- network$get_nodes() |
| 787 | 22x |
aes <- network$get_node_aes() |
| 788 | 22x |
theme <- network$get_theme() |
| 789 | ||
| 790 | 3x |
if (is.null(nodes) || nrow(nodes) == 0) return(grid::gList()) |
| 791 | ||
| 792 | 19x |
n <- nrow(nodes) |
| 793 | ||
| 794 |
# Get names for legend (use node_names aesthetic if provided, otherwise node name/label) |
|
| 795 | 19x |
if (!is.null(aes$node_names)) {
|
| 796 | 1x |
legend_names <- recycle_to_length(aes$node_names, n) |
| 797 | 18x |
} else if (!is.null(nodes$name)) {
|
| 798 | 17x |
legend_names <- nodes$name |
| 799 |
} else {
|
|
| 800 | 1x |
legend_names <- nodes$label |
| 801 |
} |
|
| 802 | ||
| 803 |
# Get fill colors |
|
| 804 | 19x |
fills <- recycle_to_length( |
| 805 | 19x |
if (!is.null(aes$fill)) aes$fill else "#4A90D9", |
| 806 | 19x |
n |
| 807 |
) |
|
| 808 | ||
| 809 |
# Get unique name-color pairs (to avoid duplicate legend entries) |
|
| 810 | 19x |
legend_data <- data.frame( |
| 811 | 19x |
name = legend_names, |
| 812 | 19x |
fill = fills, |
| 813 | 19x |
stringsAsFactors = FALSE |
| 814 |
) |
|
| 815 | 19x |
legend_data <- unique(legend_data) |
| 816 | ||
| 817 | 19x |
n_items <- nrow(legend_data) |
| 818 | ! |
if (n_items == 0) return(grid::gList()) |
| 819 | ||
| 820 |
# Legend styling |
|
| 821 | 19x |
swatch_size <- 0.02 # Size of color swatch |
| 822 | 19x |
text_size <- 8 # Text size |
| 823 | 19x |
item_height <- 0.04 # Height per item |
| 824 | 19x |
padding <- 0.02 # Padding from edge |
| 825 | 19x |
spacing <- 0.01 # Space between swatch and text |
| 826 | ||
| 827 |
# Calculate legend dimensions |
|
| 828 | 19x |
legend_height <- n_items * item_height + padding |
| 829 | 19x |
legend_width <- 0.15 # Fixed width |
| 830 | ||
| 831 |
# Calculate position based on legend_position parameter |
|
| 832 | 19x |
if (position == "topright") {
|
| 833 | 10x |
x_start <- 1 - padding - legend_width |
| 834 | 10x |
y_start <- 1 - padding |
| 835 | 9x |
} else if (position == "topleft") {
|
| 836 | 3x |
x_start <- padding |
| 837 | 3x |
y_start <- 1 - padding |
| 838 | 6x |
} else if (position == "bottomright") {
|
| 839 | 2x |
x_start <- 1 - padding - legend_width |
| 840 | 2x |
y_start <- padding + legend_height |
| 841 | 4x |
} else if (position == "bottomleft") {
|
| 842 | 3x |
x_start <- padding |
| 843 | 3x |
y_start <- padding + legend_height |
| 844 |
} else {
|
|
| 845 |
# Default to topright |
|
| 846 | 1x |
x_start <- 1 - padding - legend_width |
| 847 | 1x |
y_start <- 1 - padding |
| 848 |
} |
|
| 849 | ||
| 850 | 19x |
grobs <- list() |
| 851 | ||
| 852 |
# Optional: Add legend background |
|
| 853 | 19x |
bg_color <- if (!is.null(theme)) theme$get("background") else "white"
|
| 854 | 19x |
grobs[[1]] <- grid::rectGrob( |
| 855 | 19x |
x = grid::unit(x_start - padding/2, "npc"), |
| 856 | 19x |
y = grid::unit(y_start - legend_height/2 + padding/2, "npc"), |
| 857 | 19x |
width = grid::unit(legend_width + padding, "npc"), |
| 858 | 19x |
height = grid::unit(legend_height + padding, "npc"), |
| 859 | 19x |
just = c("left", "center"),
|
| 860 | 19x |
gp = grid::gpar(fill = adjustcolor(bg_color, alpha.f = 0.9), |
| 861 | 19x |
col = "gray70", lwd = 0.5) |
| 862 |
) |
|
| 863 | ||
| 864 |
# Draw each legend item |
|
| 865 | 19x |
for (i in seq_len(n_items)) {
|
| 866 | 67x |
y_pos <- y_start - (i - 0.5) * item_height |
| 867 | ||
| 868 |
# Color swatch |
|
| 869 | 67x |
grobs[[length(grobs) + 1]] <- grid::rectGrob( |
| 870 | 67x |
x = grid::unit(x_start, "npc"), |
| 871 | 67x |
y = grid::unit(y_pos, "npc"), |
| 872 | 67x |
width = grid::unit(swatch_size, "npc"), |
| 873 | 67x |
height = grid::unit(swatch_size, "npc"), |
| 874 | 67x |
just = c("left", "center"),
|
| 875 | 67x |
gp = grid::gpar(fill = legend_data$fill[i], col = "gray50", lwd = 0.5) |
| 876 |
) |
|
| 877 | ||
| 878 |
# Text label |
|
| 879 | 67x |
text_color <- if (!is.null(theme)) theme$get("label_color") else "black"
|
| 880 | 67x |
grobs[[length(grobs) + 1]] <- grid::textGrob( |
| 881 | 67x |
label = legend_data$name[i], |
| 882 | 67x |
x = grid::unit(x_start + swatch_size + spacing, "npc"), |
| 883 | 67x |
y = grid::unit(y_pos, "npc"), |
| 884 | 67x |
just = c("left", "center"),
|
| 885 | 67x |
gp = grid::gpar(fontsize = text_size, col = text_color) |
| 886 |
) |
|
| 887 |
} |
|
| 888 | ||
| 889 | 19x |
do.call(grid::gList, grobs) |
| 890 |
} |
|
| 891 | ||
| 892 |
#' @rdname soplot |
|
| 893 |
#' @export |
|
| 894 |
sn_render <- soplot |
| 1 |
#' @title Shape Registry Functions |
|
| 2 |
#' @description Functions for registering built-in shapes. |
|
| 3 |
#' @name shapes-registry |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Register Built-in Shapes |
|
| 8 |
#' |
|
| 9 |
#' Register all built-in node shapes. |
|
| 10 |
#' |
|
| 11 |
#' @keywords internal |
|
| 12 |
register_builtin_shapes <- function() {
|
|
| 13 |
# Basic shapes |
|
| 14 | 2x |
register_shape("circle", draw_circle)
|
| 15 | 2x |
register_shape("square", draw_square)
|
| 16 | 2x |
register_shape("triangle", draw_triangle)
|
| 17 | 2x |
register_shape("diamond", draw_diamond)
|
| 18 | 2x |
register_shape("pentagon", draw_pentagon)
|
| 19 | 2x |
register_shape("hexagon", draw_hexagon)
|
| 20 | ||
| 21 |
# Special shapes |
|
| 22 | 2x |
register_shape("ellipse", draw_ellipse)
|
| 23 | 2x |
register_shape("heart", draw_heart)
|
| 24 | 2x |
register_shape("star", draw_star)
|
| 25 | 2x |
register_shape("pie", draw_pie)
|
| 26 | 2x |
register_shape("donut", draw_donut)
|
| 27 | 2x |
register_shape("polygon_donut", draw_polygon_donut)
|
| 28 | 2x |
register_shape("donut_pie", draw_donut_pie)
|
| 29 | 2x |
register_shape("double_donut_pie", draw_double_donut_pie)
|
| 30 | 2x |
register_shape("cross", draw_cross)
|
| 31 | 2x |
register_shape("plus", draw_cross) # Alias
|
| 32 | ||
| 33 |
# AI-themed shapes |
|
| 34 | 2x |
register_shape("neural", draw_neural)
|
| 35 | 2x |
register_shape("chip", draw_chip)
|
| 36 | 2x |
register_shape("robot", draw_robot)
|
| 37 | 2x |
register_shape("brain", draw_brain)
|
| 38 | 2x |
register_shape("network", draw_network)
|
| 39 | 2x |
register_shape("database", draw_database)
|
| 40 | 2x |
register_shape("cloud", draw_cloud)
|
| 41 | 2x |
register_shape("gear", draw_gear)
|
| 42 | ||
| 43 |
# Rectangle (alias for square with different aspect) |
|
| 44 | 2x |
register_shape("rectangle", function(x, y, size, fill, border_color,
|
| 45 | 2x |
border_width, alpha = 1, aspect = 1.5, ...) {
|
| 46 | 3x |
fill_col <- adjust_alpha(fill, alpha) |
| 47 | 3x |
border_col <- adjust_alpha(border_color, alpha) |
| 48 | ||
| 49 | 3x |
grid::rectGrob( |
| 50 | 3x |
x = grid::unit(x, "npc"), |
| 51 | 3x |
y = grid::unit(y, "npc"), |
| 52 | 3x |
width = grid::unit(size * 2 * aspect, "npc"), |
| 53 | 3x |
height = grid::unit(size * 2, "npc"), |
| 54 | 3x |
gp = grid::gpar( |
| 55 | 3x |
fill = fill_col, |
| 56 | 3x |
col = border_col, |
| 57 | 3x |
lwd = border_width |
| 58 |
) |
|
| 59 |
) |
|
| 60 |
}) |
|
| 61 | ||
| 62 |
# None/invisible (for labels only) |
|
| 63 | 2x |
register_shape("none", function(x, y, size, fill, border_color,
|
| 64 | 2x |
border_width, alpha = 1, ...) {
|
| 65 | 3x |
grid::nullGrob() |
| 66 |
}) |
|
| 67 |
} |
| 1 |
#' @title Package Load and Unload Functions |
|
| 2 |
#' @description Functions called when the package is loaded or unloaded. |
|
| 3 |
#' @name zzz |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Check if a package is available |
|
| 8 |
#' |
|
| 9 |
#' Internal wrapper around requireNamespace that can be mocked in tests. |
|
| 10 |
#' |
|
| 11 |
#' @param pkg Package name. |
|
| 12 |
#' @return Logical. |
|
| 13 |
#' @keywords internal |
|
| 14 |
has_package <- function(pkg) {
|
|
| 15 | 204x |
requireNamespace(pkg, quietly = TRUE) |
| 16 |
} |
|
| 17 | ||
| 18 |
.onLoad <- function(libname, pkgname) {
|
|
| 19 |
# Initialize registries |
|
| 20 | 1x |
init_registries() |
| 21 | ||
| 22 | ||
| 23 |
# Register built-in shapes |
|
| 24 | 1x |
register_builtin_shapes() |
| 25 | ||
| 26 | ||
| 27 |
# Register built-in layouts |
|
| 28 | 1x |
register_builtin_layouts() |
| 29 | ||
| 30 | ||
| 31 |
# Register built-in themes |
|
| 32 | 1x |
register_builtin_themes() |
| 33 | ||
| 34 |
# Register built-in palettes |
|
| 35 | 1x |
register_builtin_palettes() |
| 36 |
} |
|
| 37 | ||
| 38 |
.onAttach <- function(libname, pkgname) {
|
|
| 39 | 2x |
packageStartupMessage( |
| 40 | 2x |
"cograph: Modern Network Visualization for R\n", |
| 41 | 2x |
"Version: ", utils::packageVersion(pkgname), "\n", |
| 42 | 2x |
"Type ?cograph for help" |
| 43 |
) |
|
| 44 |
} |
| 1 |
#' @title qgraph Input Parsing |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing qgraph objects. |
|
| 4 |
#' @name input-qgraph |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse qgraph Object |
|
| 8 |
#' |
|
| 9 |
#' Convert a qgraph object to internal network format. |
|
| 10 |
#' |
|
| 11 |
#' @param q A qgraph object from the qgraph package. |
|
| 12 |
#' @param directed Logical. Force directed interpretation. NULL uses qgraph's setting. |
|
| 13 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 14 |
#' @noRd |
|
| 15 |
parse_qgraph <- function(q, directed = NULL) {
|
|
| 16 |
# Check if qgraph is available |
|
| 17 | 22x |
if (!has_package("qgraph")) {
|
| 18 | 1x |
stop("Package 'qgraph' is required for qgraph input. ",
|
| 19 | 1x |
"Please install it with: install.packages('qgraph')",
|
| 20 | 1x |
call. = FALSE) |
| 21 |
} |
|
| 22 | ||
| 23 |
# Validate input |
|
| 24 | 21x |
if (!inherits(q, "qgraph") && is.null(q$Arguments)) {
|
| 25 | 3x |
stop("Input must be a qgraph object", call. = FALSE)
|
| 26 |
} |
|
| 27 | ||
| 28 |
# Get edge list |
|
| 29 | 18x |
el <- q$Edgelist |
| 30 | ||
| 31 |
# Get directedness |
|
| 32 | 18x |
if (is.null(directed)) {
|
| 33 | 16x |
if (!is.null(el$directed)) {
|
| 34 | 11x |
directed <- any(el$directed) |
| 35 |
} else {
|
|
| 36 |
# Fall back to checking matrix symmetry |
|
| 37 | 5x |
input_mat <- q$Arguments$input |
| 38 | 5x |
directed <- if (!is.null(input_mat) && is.matrix(input_mat)) {
|
| 39 | 3x |
!isSymmetric(input_mat) |
| 40 |
} else {
|
|
| 41 | 2x |
FALSE |
| 42 |
} |
|
| 43 |
} |
|
| 44 |
} |
|
| 45 | ||
| 46 |
# Get node information |
|
| 47 | 18x |
ga_nodes <- q$graphAttributes$Nodes |
| 48 | 18x |
if (!is.null(ga_nodes$names)) {
|
| 49 | 13x |
labels <- ga_nodes$names |
| 50 | 13x |
n <- length(labels) |
| 51 | 5x |
} else if (!is.null(ga_nodes$labels)) {
|
| 52 | 1x |
labels <- ga_nodes$labels |
| 53 | 1x |
n <- length(labels) |
| 54 |
} else {
|
|
| 55 |
# Infer from input matrix or edge list |
|
| 56 | 4x |
input_mat <- q$Arguments$input |
| 57 | 4x |
if (!is.null(input_mat) && is.matrix(input_mat)) {
|
| 58 | 1x |
n <- nrow(input_mat) |
| 59 |
} else {
|
|
| 60 | 3x |
n <- max(c(el$from, el$to)) |
| 61 |
} |
|
| 62 | 4x |
labels <- as.character(seq_len(n)) |
| 63 |
} |
|
| 64 | ||
| 65 |
# Get edges |
|
| 66 | 18x |
if (is.null(el) || length(el$from) == 0) {
|
| 67 | 1x |
from_idx <- integer(0) |
| 68 | 1x |
to_idx <- integer(0) |
| 69 | 1x |
weight_vals <- numeric(0) |
| 70 |
} else {
|
|
| 71 | 17x |
from_idx <- el$from |
| 72 | 17x |
to_idx <- el$to |
| 73 | 17x |
weight_vals <- if (!is.null(el$weight)) el$weight else rep(1, length(el$from)) |
| 74 |
} |
|
| 75 | ||
| 76 |
# Create data structures |
|
| 77 | 18x |
nodes <- create_nodes_df(n, labels) |
| 78 | 18x |
edges <- create_edges_df(from_idx, to_idx, weight_vals, directed) |
| 79 | ||
| 80 |
# Add layout if available |
|
| 81 | 18x |
if (!is.null(q$layout) && is.matrix(q$layout) && nrow(q$layout) == n) {
|
| 82 | 3x |
nodes$x <- q$layout[, 1] |
| 83 | 3x |
nodes$y <- q$layout[, 2] |
| 84 |
} |
|
| 85 | ||
| 86 | 18x |
list( |
| 87 | 18x |
nodes = nodes, |
| 88 | 18x |
edges = edges, |
| 89 | 18x |
directed = directed, |
| 90 | 18x |
weights = weight_vals |
| 91 |
) |
|
| 92 |
} |
| 1 |
#' @title Statnet Network Input Parsing |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing statnet network objects. |
|
| 4 |
#' @name input-statnet |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse Statnet Network Object |
|
| 8 |
#' |
|
| 9 |
#' Convert a statnet network object to internal network format. |
|
| 10 |
#' |
|
| 11 |
#' @param net A network object from the statnet/network package. |
|
| 12 |
#' @param directed Logical. Force directed interpretation. NULL uses network's setting. |
|
| 13 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 14 |
#' @noRd |
|
| 15 |
parse_statnet <- function(net, directed = NULL) {
|
|
| 16 |
# Check if network package is available |
|
| 17 | 21x |
if (!has_package("network")) {
|
| 18 | 1x |
stop("Package 'network' is required for statnet network input. ",
|
| 19 | 1x |
"Please install it with: install.packages('network')",
|
| 20 | 1x |
call. = FALSE) |
| 21 |
} |
|
| 22 | ||
| 23 |
# Validate input |
|
| 24 | 20x |
if (!inherits(net, "network")) {
|
| 25 | 3x |
stop("Input must be a network object", call. = FALSE)
|
| 26 |
} |
|
| 27 | ||
| 28 |
# Get directedness |
|
| 29 | 17x |
if (is.null(directed)) {
|
| 30 | 16x |
directed <- network::is.directed(net) |
| 31 |
} |
|
| 32 | ||
| 33 |
# Get number of nodes |
|
| 34 | 17x |
n <- network::network.size(net) |
| 35 | ||
| 36 |
# Get node labels |
|
| 37 | 17x |
labels <- network::network.vertex.names(net) |
| 38 | 17x |
if (is.null(labels) || all(is.na(labels))) {
|
| 39 | ! |
labels <- as.character(seq_len(n)) |
| 40 |
} |
|
| 41 | ||
| 42 |
# Get edges as matrix |
|
| 43 | 17x |
edge_matrix <- network::as.edgelist(net) |
| 44 | ||
| 45 | 17x |
if (is.null(edge_matrix) || nrow(edge_matrix) == 0) {
|
| 46 |
# Empty network |
|
| 47 | 1x |
from_idx <- integer(0) |
| 48 | 1x |
to_idx <- integer(0) |
| 49 | 1x |
weight_vals <- numeric(0) |
| 50 |
} else {
|
|
| 51 | 16x |
from_idx <- edge_matrix[, 1] |
| 52 | 16x |
to_idx <- edge_matrix[, 2] |
| 53 | ||
| 54 |
# Get edge weights |
|
| 55 | 16x |
edge_attrs <- network::list.edge.attributes(net) |
| 56 | 16x |
if ("weight" %in% edge_attrs) {
|
| 57 | 1x |
weight_vals <- network::get.edge.value(net, "weight") |
| 58 |
} else {
|
|
| 59 | 15x |
weight_vals <- rep(1, nrow(edge_matrix)) |
| 60 |
} |
|
| 61 |
} |
|
| 62 | ||
| 63 |
# Create data structures |
|
| 64 | 17x |
nodes <- create_nodes_df(n, labels) |
| 65 | 17x |
edges <- create_edges_df(from_idx, to_idx, weight_vals, directed) |
| 66 | ||
| 67 |
# Add additional vertex attributes |
|
| 68 | 17x |
v_attrs <- network::list.vertex.attributes(net) |
| 69 | 17x |
for (attr in v_attrs) {
|
| 70 | 34x |
if (!attr %in% c("vertex.names", "na")) {
|
| 71 | 1x |
nodes[[attr]] <- network::get.vertex.attribute(net, attr) |
| 72 |
} |
|
| 73 |
} |
|
| 74 | ||
| 75 |
# Add additional edge attributes |
|
| 76 | 17x |
if (nrow(edges) > 0) {
|
| 77 | 16x |
e_attrs <- network::list.edge.attributes(net) |
| 78 | 16x |
for (attr in e_attrs) {
|
| 79 | 18x |
if (!attr %in% c("weight", "na")) {
|
| 80 | 1x |
edges[[attr]] <- network::get.edge.value(net, attr) |
| 81 |
} |
|
| 82 |
} |
|
| 83 |
} |
|
| 84 | ||
| 85 | 17x |
list( |
| 86 | 17x |
nodes = nodes, |
| 87 | 17x |
edges = edges, |
| 88 | 17x |
directed = directed, |
| 89 | 17x |
weights = weight_vals |
| 90 |
) |
|
| 91 |
} |
| 1 |
#' @title splot Parameter Vectorization Helpers |
|
| 2 |
#' @description Functions for resolving and vectorizing splot() parameters. |
|
| 3 |
#' @name splot-params |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Resolve Edge Colors |
|
| 8 |
#' |
|
| 9 |
#' Determines edge colors based on weights, explicit colors, or defaults. |
|
| 10 |
#' |
|
| 11 |
#' @param edges Edge data frame with from, to, weight columns. |
|
| 12 |
#' @param edge.color User-specified edge color(s) or NULL. |
|
| 13 |
#' @param posCol Color for positive weights. |
|
| 14 |
#' @param negCol Color for negative weights. |
|
| 15 |
#' @param default_col Default color when no weight. |
|
| 16 |
#' @return Vector of colors for each edge. |
|
| 17 |
#' @keywords internal |
|
| 18 |
resolve_edge_colors <- function(edges, edge.color = NULL, posCol = "#2E7D32", |
|
| 19 |
negCol = "#C62828", default_col = "gray50") {
|
|
| 20 | 659x |
m <- nrow(edges) |
| 21 | 1x |
if (m == 0) return(character(0)) |
| 22 | ||
| 23 | 658x |
if (!is.null(edge.color)) {
|
| 24 |
# User-specified colors |
|
| 25 | 117x |
return(recycle_to_length(edge.color, m)) |
| 26 |
} |
|
| 27 | ||
| 28 |
# Color by weight sign |
|
| 29 | 541x |
if ("weight" %in% names(edges)) {
|
| 30 | 539x |
weights <- edges$weight |
| 31 | 539x |
colors <- ifelse( |
| 32 | 539x |
weights > 0, posCol, |
| 33 | 539x |
ifelse(weights < 0, negCol, default_col) |
| 34 |
) |
|
| 35 | 539x |
return(colors) |
| 36 |
} |
|
| 37 | ||
| 38 |
# Default |
|
| 39 | 2x |
rep(default_col, m) |
| 40 |
} |
|
| 41 | ||
| 42 |
#' Resolve Edge Widths |
|
| 43 |
#' |
|
| 44 |
#' Determines edge widths based on weights or explicit values. |
|
| 45 |
#' Supports multiple scaling modes, two-tier cutoff, and output range specification. |
|
| 46 |
#' |
|
| 47 |
#' @param edges Edge data frame. |
|
| 48 |
#' @param edge.width User-specified width(s) or NULL. |
|
| 49 |
#' @param esize Base edge size. NULL uses adaptive sizing based on n_nodes. |
|
| 50 |
#' @param n_nodes Number of nodes (for adaptive esize calculation). |
|
| 51 |
#' @param directed Whether network is directed. |
|
| 52 |
#' @param maximum Maximum weight for scaling (NULL for auto). |
|
| 53 |
#' @param minimum Minimum weight threshold. |
|
| 54 |
#' @param cut Two-tier cutoff. NULL = auto (75th pct), 0 = disabled. |
|
| 55 |
#' @param edge_width_range Output width range c(min, max). |
|
| 56 |
#' @param edge_scale_mode Scaling mode: "linear", "log", "sqrt", "rank". |
|
| 57 |
#' @param scaling Scaling mode for constants: "default" or "legacy". |
|
| 58 |
#' @param base_width Legacy: Base width value. |
|
| 59 |
#' @param scale_factor Legacy: Width scaling factor. |
|
| 60 |
#' @return Vector of widths for each edge. |
|
| 61 |
#' @keywords internal |
|
| 62 |
resolve_edge_widths <- function(edges, |
|
| 63 |
edge.width = NULL, |
|
| 64 |
esize = NULL, |
|
| 65 |
n_nodes = NULL, |
|
| 66 |
directed = FALSE, |
|
| 67 |
maximum = NULL, |
|
| 68 |
minimum = 0, |
|
| 69 |
cut = NULL, |
|
| 70 |
edge_width_range = NULL, |
|
| 71 |
edge_scale_mode = NULL, |
|
| 72 |
scaling = "default", |
|
| 73 |
base_width = NULL, |
|
| 74 |
scale_factor = NULL) {
|
|
| 75 | 658x |
m <- nrow(edges) |
| 76 | 1x |
if (m == 0) return(numeric(0)) |
| 77 | ||
| 78 |
# If explicit widths provided, use them directly |
|
| 79 | 657x |
if (!is.null(edge.width)) {
|
| 80 | 4x |
return(recycle_to_length(edge.width, m)) |
| 81 |
} |
|
| 82 | ||
| 83 |
# Get scale constants |
|
| 84 | 653x |
scale <- get_scale_constants(scaling) |
| 85 | ||
| 86 |
# Use defaults from scale constants if not specified |
|
| 87 | 653x |
if (is.null(edge_width_range)) {
|
| 88 | 2x |
edge_width_range <- scale$edge_width_range |
| 89 |
} |
|
| 90 | 653x |
if (is.null(edge_scale_mode)) {
|
| 91 | 2x |
edge_scale_mode <- scale$edge_scale_mode |
| 92 |
} |
|
| 93 | ||
| 94 |
# Scale by weight if available |
|
| 95 | 653x |
if ("weight" %in% names(edges)) {
|
| 96 | 652x |
return(scale_edge_widths( |
| 97 | 652x |
weights = edges$weight, |
| 98 | 652x |
esize = esize, |
| 99 | 652x |
n_nodes = n_nodes, |
| 100 | 652x |
directed = directed, |
| 101 | 652x |
mode = edge_scale_mode, |
| 102 | 652x |
maximum = maximum, |
| 103 | 652x |
minimum = minimum, |
| 104 | 652x |
cut = cut, |
| 105 | 652x |
range = edge_width_range |
| 106 |
)) |
|
| 107 |
} |
|
| 108 | ||
| 109 |
# Default width when no weights - use scale constants |
|
| 110 | 1x |
rep(scale$edge_width_default, m) |
| 111 |
} |
|
| 112 | ||
| 113 |
#' Resolve Node Sizes |
|
| 114 |
#' |
|
| 115 |
#' Converts vsize parameter to user coordinate sizes. |
|
| 116 |
#' |
|
| 117 |
#' @param vsize User-specified node size(s). |
|
| 118 |
#' @param n Number of nodes. |
|
| 119 |
#' @param default_size Default size if NULL (uses scale constants if NULL). |
|
| 120 |
#' @param scale_factor Scale factor to apply (uses scale constants if NULL). |
|
| 121 |
#' @param scaling Scaling mode: "default" or "legacy". |
|
| 122 |
#' @return Vector of node sizes. |
|
| 123 |
#' @keywords internal |
|
| 124 |
resolve_node_sizes <- function(vsize, n, default_size = NULL, scale_factor = NULL, |
|
| 125 |
scaling = "default") {
|
|
| 126 | 671x |
scale <- get_scale_constants(scaling) |
| 127 | ||
| 128 |
# Use scale constants if not explicitly provided |
|
| 129 | 671x |
if (is.null(default_size)) {
|
| 130 | 671x |
default_size <- scale$node_default |
| 131 |
} |
|
| 132 | 671x |
if (is.null(scale_factor)) {
|
| 133 | 671x |
scale_factor <- scale$node_factor |
| 134 |
} |
|
| 135 | ||
| 136 | 671x |
if (is.null(vsize)) {
|
| 137 | 541x |
vsize <- default_size |
| 138 |
} |
|
| 139 | ||
| 140 | 671x |
sizes <- recycle_to_length(vsize, n) |
| 141 | ||
| 142 |
# Convert to user coordinates (qgraph-style sizing) |
|
| 143 | 671x |
sizes * scale_factor |
| 144 |
} |
|
| 145 | ||
| 146 |
#' Resolve Label Sizes |
|
| 147 |
#' |
|
| 148 |
#' Determines label sizes, either independent (new default) or coupled to node size (legacy). |
|
| 149 |
#' |
|
| 150 |
#' @param label_size User-specified label size(s) or NULL. |
|
| 151 |
#' @param node_size_usr Node sizes in user coordinates (for legacy coupled mode). |
|
| 152 |
#' @param n Number of nodes. |
|
| 153 |
#' @param scaling Scaling mode: "default" or "legacy". |
|
| 154 |
#' @return Vector of label sizes (cex values). |
|
| 155 |
#' @keywords internal |
|
| 156 |
resolve_label_sizes <- function(label_size, node_size_usr, n, scaling = "default") {
|
|
| 157 | 669x |
scale <- get_scale_constants(scaling) |
| 158 | ||
| 159 | 669x |
if (!is.null(label_size)) {
|
| 160 |
# User explicitly specified - use as-is |
|
| 161 | 6x |
return(recycle_to_length(label_size, n)) |
| 162 |
} |
|
| 163 | ||
| 164 | 663x |
if (scale$label_coupled) {
|
| 165 |
# Legacy mode: couple to node size (original behavior) |
|
| 166 |
# vsize_usr * 8, capped at 1 |
|
| 167 | 1x |
return(pmin(1, node_size_usr * 8)) |
| 168 |
} |
|
| 169 | ||
| 170 |
# New default: independent label size |
|
| 171 | 662x |
rep(scale$label_default, n) |
| 172 |
} |
|
| 173 | ||
| 174 |
#' Resolve Node Colors |
|
| 175 |
#' |
|
| 176 |
#' Determines node colors from various inputs. |
|
| 177 |
#' |
|
| 178 |
#' @param color User-specified color(s) or NULL. |
|
| 179 |
#' @param n Number of nodes. |
|
| 180 |
#' @param nodes Node data frame (for group coloring). |
|
| 181 |
#' @param groups Group assignments for color mapping. |
|
| 182 |
#' @param default_col Default node color. |
|
| 183 |
#' @return Vector of colors for each node. |
|
| 184 |
#' @keywords internal |
|
| 185 |
resolve_node_colors <- function(color, n, nodes = NULL, groups = NULL, |
|
| 186 |
default_col = "#4A90D9") {
|
|
| 187 | 671x |
if (!is.null(color)) {
|
| 188 | 155x |
return(recycle_to_length(color, n)) |
| 189 |
} |
|
| 190 | ||
| 191 |
# Color by groups if provided |
|
| 192 | 516x |
if (!is.null(groups)) {
|
| 193 | 12x |
unique_groups <- unique(groups) |
| 194 | 12x |
n_groups <- length(unique_groups) |
| 195 | 12x |
palette <- grDevices::rainbow(n_groups, s = 0.7, v = 0.9) |
| 196 | 12x |
colors <- palette[match(groups, unique_groups)] |
| 197 | 12x |
return(colors) |
| 198 |
} |
|
| 199 | ||
| 200 |
# Color from node data if available |
|
| 201 | 504x |
if (!is.null(nodes) && "color" %in% names(nodes)) {
|
| 202 | 1x |
return(nodes$color) |
| 203 |
} |
|
| 204 | ||
| 205 | 503x |
rep(default_col, n) |
| 206 |
} |
|
| 207 | ||
| 208 |
#' Resolve Labels |
|
| 209 |
#' |
|
| 210 |
#' Determines node labels from various inputs. |
|
| 211 |
#' |
|
| 212 |
#' @param labels User-specified labels: TRUE, FALSE, character vector, or NULL. |
|
| 213 |
#' @param nodes Node data frame. |
|
| 214 |
#' @param n Number of nodes. |
|
| 215 |
#' @return Character vector of labels (or NULL for no labels). |
|
| 216 |
#' @keywords internal |
|
| 217 |
resolve_labels <- function(labels, nodes, n) {
|
|
| 218 | 672x |
if (is.null(labels) || identical(labels, FALSE)) {
|
| 219 | 4x |
return(NULL) |
| 220 |
} |
|
| 221 | ||
| 222 | 668x |
if (identical(labels, TRUE)) {
|
| 223 |
# Use node labels from data or indices |
|
| 224 | 643x |
if (!is.null(nodes) && "label" %in% names(nodes)) {
|
| 225 | 642x |
return(as.character(nodes$label)) |
| 226 |
} |
|
| 227 | 1x |
return(as.character(seq_len(n))) |
| 228 |
} |
|
| 229 | ||
| 230 |
# User-provided labels |
|
| 231 | 25x |
recycle_to_length(as.character(labels), n) |
| 232 |
} |
|
| 233 | ||
| 234 |
#' Resolve Edge Labels |
|
| 235 |
#' |
|
| 236 |
#' Determines edge labels from various inputs. |
|
| 237 |
#' |
|
| 238 |
#' @param edge.labels User-specified labels: TRUE, FALSE, character vector, or NULL. |
|
| 239 |
#' @param edges Edge data frame. |
|
| 240 |
#' @param m Number of edges. |
|
| 241 |
#' @return Character vector of labels (or NULL for no labels). |
|
| 242 |
#' @keywords internal |
|
| 243 |
resolve_edge_labels <- function(edge.labels, edges, m) {
|
|
| 244 | 656x |
if (is.null(edge.labels) || identical(edge.labels, FALSE)) {
|
| 245 | 508x |
return(NULL) |
| 246 |
} |
|
| 247 | ||
| 248 | 148x |
if (identical(edge.labels, TRUE)) {
|
| 249 |
# Use weights as labels if available |
|
| 250 | 144x |
if (!is.null(edges) && "weight" %in% names(edges)) {
|
| 251 | 143x |
return(as.character(round(edges$weight, 2))) |
| 252 |
} |
|
| 253 | 1x |
return(rep("", m))
|
| 254 |
} |
|
| 255 | ||
| 256 |
# User-provided labels |
|
| 257 | 4x |
recycle_to_length(as.character(edge.labels), m) |
| 258 |
} |
|
| 259 | ||
| 260 |
#' Resolve Shape Parameter |
|
| 261 |
#' |
|
| 262 |
#' Converts shape specification to vector of shape names. |
|
| 263 |
#' |
|
| 264 |
#' @param shape Shape specification. |
|
| 265 |
#' @param n Number of nodes. |
|
| 266 |
#' @return Character vector of shape names. |
|
| 267 |
#' @keywords internal |
|
| 268 |
resolve_shapes <- function(shape, n) {
|
|
| 269 | 669x |
if (is.null(shape)) {
|
| 270 | 1x |
shape <- "circle" |
| 271 |
} |
|
| 272 | 669x |
recycle_to_length(shape, n) |
| 273 |
} |
|
| 274 | ||
| 275 |
#' Resolve Curvature Parameter |
|
| 276 |
#' |
|
| 277 |
#' Determines edge curvatures, handling reciprocal edges. |
|
| 278 |
#' |
|
| 279 |
#' @param curve User-specified curvature(s). |
|
| 280 |
#' @param edges Edge data frame. |
|
| 281 |
#' @param curveScale Logical: scale curvature for reciprocal edges? |
|
| 282 |
#' @param default_curve Default curvature for reciprocal edges. |
|
| 283 |
#' @return Vector of curvatures. |
|
| 284 |
#' @keywords internal |
|
| 285 |
resolve_curvatures <- function(curve, edges, curveScale = TRUE, |
|
| 286 |
default_curve = 0.2) {
|
|
| 287 | 5x |
m <- nrow(edges) |
| 288 | 1x |
if (m == 0) return(numeric(0)) |
| 289 | ||
| 290 | 4x |
curves <- recycle_to_length(curve, m) |
| 291 | ||
| 292 | 4x |
if (!curveScale) {
|
| 293 | 1x |
return(curves) |
| 294 |
} |
|
| 295 | ||
| 296 |
# Identify reciprocal edges and apply default curvature |
|
| 297 | 3x |
for (i in seq_len(m)) {
|
| 298 | 7x |
from_i <- edges$from[i] |
| 299 | 7x |
to_i <- edges$to[i] |
| 300 | ||
| 301 | 1x |
if (from_i == to_i) next # Skip self-loops |
| 302 | ||
| 303 |
# Check for reciprocal |
|
| 304 | 6x |
for (j in seq_len(m)) {
|
| 305 | 14x |
if (j != i && edges$from[j] == to_i && edges$to[j] == from_i) {
|
| 306 |
# Found reciprocal - apply curvature if not already set |
|
| 307 | 2x |
if (curves[i] == 0) {
|
| 308 | 2x |
curves[i] <- default_curve |
| 309 |
} |
|
| 310 | 2x |
break |
| 311 |
} |
|
| 312 |
} |
|
| 313 |
} |
|
| 314 | ||
| 315 | 3x |
curves |
| 316 |
} |
|
| 317 | ||
| 318 |
#' Resolve Loop Rotation |
|
| 319 |
#' |
|
| 320 |
#' Determines rotation angle for self-loops. |
|
| 321 |
#' |
|
| 322 |
#' @param loopRotation User-specified rotation(s) or NULL. |
|
| 323 |
#' @param edges Edge data frame. |
|
| 324 |
#' @param layout Layout coordinates (to auto-calculate optimal rotation). |
|
| 325 |
#' @return Vector of rotation angles in radians. |
|
| 326 |
#' @keywords internal |
|
| 327 |
resolve_loop_rotation <- function(loopRotation, edges, layout = NULL) {
|
|
| 328 | 659x |
m <- nrow(edges) |
| 329 | 1x |
if (m == 0) return(numeric(0)) |
| 330 | ||
| 331 |
# Find self-loops |
|
| 332 | 658x |
is_loop <- edges$from == edges$to |
| 333 | ||
| 334 | 658x |
if (is.null(loopRotation)) {
|
| 335 |
# Default: loop at top (pi/2) |
|
| 336 | 655x |
rotations <- rep(pi/2, m) |
| 337 | ||
| 338 |
# If layout provided, point away from center |
|
| 339 | 655x |
if (!is.null(layout)) {
|
| 340 | 654x |
center_x <- mean(layout[, 1], na.rm = TRUE) |
| 341 | 654x |
center_y <- mean(layout[, 2], na.rm = TRUE) |
| 342 | ||
| 343 | 654x |
for (i in which(is_loop)) {
|
| 344 | 47x |
node_idx <- edges$from[i] |
| 345 | 47x |
node_x <- layout[node_idx, 1] |
| 346 | 47x |
node_y <- layout[node_idx, 2] |
| 347 | ||
| 348 |
# Angle away from center |
|
| 349 | 47x |
rotations[i] <- atan2(node_y - center_y, node_x - center_x) |
| 350 |
} |
|
| 351 |
} |
|
| 352 | ||
| 353 | 655x |
return(rotations) |
| 354 |
} |
|
| 355 | ||
| 356 | 3x |
recycle_to_length(loopRotation, m) |
| 357 |
} |
|
| 358 | ||
| 359 |
#' Filter Edges by Weight Threshold |
|
| 360 |
#' |
|
| 361 |
#' Removes edges below the minimum weight threshold. |
|
| 362 |
#' |
|
| 363 |
#' @param edges Edge data frame. |
|
| 364 |
#' @param minimum Minimum absolute weight to include. |
|
| 365 |
#' @return Filtered edge data frame. |
|
| 366 |
#' @keywords internal |
|
| 367 |
filter_edges_by_weight <- function(edges, minimum = 0) {
|
|
| 368 | 657x |
if (minimum == 0 || !"weight" %in% names(edges)) {
|
| 369 | 648x |
return(edges) |
| 370 |
} |
|
| 371 | ||
| 372 | 9x |
edges[abs(edges$weight) >= minimum, , drop = FALSE] |
| 373 |
} |
|
| 374 | ||
| 375 |
#' Get Edge Rendering Order |
|
| 376 |
#' |
|
| 377 |
#' Returns indices for rendering edges from weakest to strongest. |
|
| 378 |
#' |
|
| 379 |
#' @param edges Edge data frame. |
|
| 380 |
#' @return Integer vector of indices. |
|
| 381 |
#' @keywords internal |
|
| 382 |
get_edge_order <- function(edges) {
|
|
| 383 | 662x |
if (!"weight" %in% names(edges) || nrow(edges) == 0) {
|
| 384 | 2x |
return(seq_len(nrow(edges))) |
| 385 |
} |
|
| 386 | ||
| 387 | 660x |
order(abs(edges$weight)) |
| 388 |
} |
|
| 389 | ||
| 390 |
#' Get Node Rendering Order |
|
| 391 |
#' |
|
| 392 |
#' Returns indices for rendering nodes from largest to smallest. |
|
| 393 |
#' |
|
| 394 |
#' @param sizes Vector of node sizes. |
|
| 395 |
#' @return Integer vector of indices. |
|
| 396 |
#' @keywords internal |
|
| 397 |
get_node_order <- function(sizes) {
|
|
| 398 | 666x |
order(sizes, decreasing = TRUE) |
| 399 |
} |
| 1 |
#' @title Deprecation Utilities |
|
| 2 |
#' @description Functions for handling deprecated parameters with backwards compatibility. |
|
| 3 |
#' @name utils-deprecation |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Handle Deprecated Parameter |
|
| 8 |
#' |
|
| 9 |
#' Handles backwards compatibility for renamed parameters. If the old parameter |
|
| 10 |
#' name is used (not NULL), issues a deprecation warning and returns the old value. |
|
| 11 |
#' Otherwise returns the new parameter value. |
|
| 12 |
#' |
|
| 13 |
#' For parameters with defaults, use `new_val_was_set` to indicate whether the |
|
| 14 |
#' user explicitly provided the new value. If FALSE (user didn't set it) and |
|
| 15 |
#' old_val is provided, the old value takes precedence. |
|
| 16 |
#' |
|
| 17 |
#' @param new_val The value of the new parameter name. |
|
| 18 |
#' @param old_val The value of the old (deprecated) parameter name. |
|
| 19 |
#' @param new_name Character string of the new parameter name (for warning message). |
|
| 20 |
#' @param old_name Character string of the old parameter name (for warning message). |
|
| 21 |
#' @param new_val_was_set Logical. TRUE if the user explicitly set new_val |
|
| 22 |
#' (FALSE means it's just the default). When NULL, the function checks if new_val |
|
| 23 |
#' is NULL to determine this. |
|
| 24 |
#' @return The effective parameter value. |
|
| 25 |
#' |
|
| 26 |
#' @keywords internal |
|
| 27 |
handle_deprecated_param <- function(new_val, old_val, new_name, old_name, |
|
| 28 |
new_val_was_set = NULL) {
|
|
| 29 |
# If old_val is provided, always warn |
|
| 30 | 8723x |
if (!is.null(old_val)) {
|
| 31 | 18x |
warning( |
| 32 | 18x |
sprintf("'%s' is deprecated, use '%s' instead.", old_name, new_name),
|
| 33 | 18x |
call. = FALSE |
| 34 |
) |
|
| 35 |
# Use old_val if new_val wasn't explicitly set |
|
| 36 | 18x |
if (is.null(new_val_was_set)) {
|
| 37 |
# Backwards compat: if new_val is NULL, old_val takes precedence |
|
| 38 | 13x |
if (is.null(new_val)) {
|
| 39 | 12x |
return(old_val) |
| 40 |
} |
|
| 41 | 5x |
} else if (!new_val_was_set) {
|
| 42 |
# new_val was the default, so use old_val |
|
| 43 | 4x |
return(old_val) |
| 44 |
} |
|
| 45 |
# If new_val was explicitly set AND old_val is provided, |
|
| 46 |
# new_val wins (user explicitly chose the new param) |
|
| 47 |
} |
|
| 48 | 8707x |
new_val |
| 49 |
} |
|
| 50 | ||
| 51 |
#' Convert Fontface String to Numeric |
|
| 52 |
#' |
|
| 53 |
#' Converts fontface string specification to numeric value used by R graphics. |
|
| 54 |
#' Handles both string ("plain", "bold", "italic", "bold.italic") and
|
|
| 55 |
#' numeric (1, 2, 3, 4) inputs for backwards compatibility. |
|
| 56 |
#' |
|
| 57 |
#' @param fontface Character or numeric fontface specification. |
|
| 58 |
#' @return Numeric fontface value (1=plain, 2=bold, 3=italic, 4=bold.italic). |
|
| 59 |
#' |
|
| 60 |
#' @keywords internal |
|
| 61 |
fontface_to_numeric <- function(fontface) {
|
|
| 62 | 684x |
if (is.numeric(fontface)) {
|
| 63 | 5x |
return(fontface) |
| 64 |
} |
|
| 65 | ||
| 66 | 679x |
switch(fontface, |
| 67 | 664x |
"plain" = 1, |
| 68 | 5x |
"bold" = 2, |
| 69 | 4x |
"italic" = 3, |
| 70 | 4x |
"bold.italic" = 4, |
| 71 | 2x |
1 # default to plain |
| 72 |
) |
|
| 73 |
} |
|
| 74 | ||
| 75 |
#' Convert Numeric Fontface to String |
|
| 76 |
#' |
|
| 77 |
#' Converts numeric fontface value to string specification. |
|
| 78 |
#' Handles both numeric (1, 2, 3, 4) and string inputs. |
|
| 79 |
#' |
|
| 80 |
#' @param fontface Numeric or character fontface specification. |
|
| 81 |
#' @return Character fontface value ("plain", "bold", "italic", "bold.italic").
|
|
| 82 |
#' |
|
| 83 |
#' @keywords internal |
|
| 84 |
fontface_to_string <- function(fontface) {
|
|
| 85 | 17x |
if (is.character(fontface)) {
|
| 86 | 4x |
return(fontface) |
| 87 |
} |
|
| 88 | ||
| 89 | 13x |
switch(as.character(fontface), |
| 90 | 3x |
"1" = "plain", |
| 91 | 3x |
"2" = "bold", |
| 92 | 3x |
"3" = "italic", |
| 93 | 3x |
"4" = "bold.italic", |
| 94 | 1x |
"plain" # default |
| 95 |
) |
|
| 96 |
} |
| 1 |
#' @title CographNetwork R6 Class |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description |
|
| 4 |
#' Core class representing a network for visualization. Stores nodes, edges, |
|
| 5 |
#' layout coordinates, and aesthetic mappings. |
|
| 6 |
#' |
|
| 7 |
#' @export |
|
| 8 |
#' @examples |
|
| 9 |
#' # Create network from adjacency matrix |
|
| 10 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 11 |
#' net <- CographNetwork$new(adj) |
|
| 12 |
#' |
|
| 13 |
#' # Access properties |
|
| 14 |
#' net$n_nodes |
|
| 15 |
#' net$n_edges |
|
| 16 |
#' net$is_directed |
|
| 17 |
CographNetwork <- R6::R6Class( |
|
| 18 |
"CographNetwork", |
|
| 19 |
public = list( |
|
| 20 |
#' @description Create a new CographNetwork object. |
|
| 21 |
#' @param input Network input (matrix, edge list, or igraph object). |
|
| 22 |
#' @param directed Logical. Force directed interpretation. NULL for auto-detect. |
|
| 23 |
#' @param node_labels Character vector of node labels. |
|
| 24 |
#' @return A new CographNetwork object. |
|
| 25 |
initialize = function(input = NULL, directed = NULL, node_labels = NULL) {
|
|
| 26 | 3276x |
if (!is.null(input)) {
|
| 27 | 1629x |
parsed <- parse_input(input, directed = directed) |
| 28 | 1625x |
private$.nodes <- parsed$nodes |
| 29 | 1625x |
private$.edges <- parsed$edges |
| 30 | 1625x |
private$.directed <- parsed$directed |
| 31 | 1625x |
private$.weights <- parsed$weights |
| 32 | ||
| 33 |
# Set node labels |
|
| 34 | 1625x |
if (!is.null(node_labels)) {
|
| 35 | 3x |
if (length(node_labels) != nrow(private$.nodes)) {
|
| 36 | 1x |
stop("node_labels length must match number of nodes", call. = FALSE)
|
| 37 |
} |
|
| 38 | 2x |
private$.nodes$label <- node_labels |
| 39 |
} |
|
| 40 |
} |
|
| 41 | ||
| 42 |
# Initialize aesthetics with defaults |
|
| 43 | 3271x |
private$.node_aes <- list( |
| 44 | 3271x |
size = 0.05, |
| 45 | 3271x |
shape = "circle", |
| 46 | 3271x |
fill = "#4A90D9", |
| 47 | 3271x |
border_color = "#2C5AA0", |
| 48 | 3271x |
border_width = 1, |
| 49 | 3271x |
alpha = 1, |
| 50 | 3271x |
label_size = 10, |
| 51 | 3271x |
label_color = "black", |
| 52 | 3271x |
label_position = "center" |
| 53 |
) |
|
| 54 | ||
| 55 | 3271x |
private$.edge_aes <- list( |
| 56 | 3271x |
width = 1, |
| 57 | 3271x |
color = "gray50", |
| 58 | 3271x |
positive_color = "#2E7D32", |
| 59 | 3271x |
negative_color = "#C62828", |
| 60 | 3271x |
alpha = 0.8, |
| 61 | 3271x |
style = "solid", |
| 62 | 3271x |
curvature = 0, |
| 63 | 3271x |
arrow_size = 0.015, |
| 64 | 3271x |
show_arrows = NULL # NULL = auto (TRUE if directed) |
| 65 |
) |
|
| 66 | ||
| 67 | 3271x |
invisible(self) |
| 68 |
}, |
|
| 69 | ||
| 70 |
#' @description Clone the network with optional modifications. |
|
| 71 |
#' @return A new CographNetwork object. |
|
| 72 |
clone_network = function() {
|
|
| 73 | 1599x |
new_net <- CographNetwork$new() |
| 74 | 1599x |
new_net$set_nodes(private$.nodes) |
| 75 | 1599x |
new_net$set_edges(private$.edges) |
| 76 | 1599x |
new_net$set_directed(private$.directed) |
| 77 | 1599x |
new_net$set_weights(private$.weights) |
| 78 | 1599x |
new_net$set_layout_coords(private$.layout) |
| 79 | 1599x |
new_net$set_node_aes(private$.node_aes) |
| 80 | 1599x |
new_net$set_edge_aes(private$.edge_aes) |
| 81 | 1599x |
new_net$set_theme(private$.theme) |
| 82 | 1599x |
if (!is.null(private$.layout_info)) {
|
| 83 | 1595x |
new_net$set_layout_info(private$.layout_info) |
| 84 |
} |
|
| 85 | 1599x |
if (!is.null(private$.plot_params)) {
|
| 86 | 1x |
new_net$set_plot_params(private$.plot_params) |
| 87 |
} |
|
| 88 | 1599x |
new_net |
| 89 |
}, |
|
| 90 | ||
| 91 |
#' @description Set nodes data frame. |
|
| 92 |
#' @param nodes Data frame with node information. |
|
| 93 |
set_nodes = function(nodes) {
|
|
| 94 | 2172x |
private$.nodes <- nodes |
| 95 | 2172x |
invisible(self) |
| 96 |
}, |
|
| 97 | ||
| 98 |
#' @description Set edges data frame. |
|
| 99 |
#' @param edges Data frame with edge information. |
|
| 100 |
set_edges = function(edges) {
|
|
| 101 | 1644x |
private$.edges <- edges |
| 102 | 1644x |
invisible(self) |
| 103 |
}, |
|
| 104 | ||
| 105 |
#' @description Set directed flag. |
|
| 106 |
#' @param directed Logical. |
|
| 107 |
set_directed = function(directed) {
|
|
| 108 | 1633x |
private$.directed <- directed |
| 109 | 1633x |
invisible(self) |
| 110 |
}, |
|
| 111 | ||
| 112 |
#' @description Set edge weights. |
|
| 113 |
#' @param weights Numeric vector of weights. |
|
| 114 |
set_weights = function(weights) {
|
|
| 115 | 1600x |
private$.weights <- weights |
| 116 | 1600x |
invisible(self) |
| 117 |
}, |
|
| 118 | ||
| 119 |
#' @description Set layout coordinates. |
|
| 120 |
#' @param coords Matrix or data frame with x, y columns. |
|
| 121 |
set_layout_coords = function(coords) {
|
|
| 122 | 3342x |
if (!is.null(coords)) {
|
| 123 | 3338x |
if (is.matrix(coords)) {
|
| 124 | 8x |
coords <- as.data.frame(coords) |
| 125 | 8x |
names(coords)[1:2] <- c("x", "y")
|
| 126 |
} |
|
| 127 | 3338x |
private$.layout <- coords |
| 128 |
# Update node positions |
|
| 129 | 3338x |
if (!is.null(private$.nodes) && nrow(private$.nodes) == nrow(coords)) {
|
| 130 | 3338x |
private$.nodes$x <- coords$x |
| 131 | 3338x |
private$.nodes$y <- coords$y |
| 132 |
} |
|
| 133 |
} |
|
| 134 | 3342x |
invisible(self) |
| 135 |
}, |
|
| 136 | ||
| 137 |
#' @description Set node aesthetics. |
|
| 138 |
#' @param aes List of aesthetic parameters. |
|
| 139 |
set_node_aes = function(aes) {
|
|
| 140 | 2274x |
private$.node_aes <- utils::modifyList(private$.node_aes, aes) |
| 141 | 2274x |
invisible(self) |
| 142 |
}, |
|
| 143 | ||
| 144 |
#' @description Set edge aesthetics. |
|
| 145 |
#' @param aes List of aesthetic parameters. |
|
| 146 |
set_edge_aes = function(aes) {
|
|
| 147 | 2268x |
private$.edge_aes <- utils::modifyList(private$.edge_aes, aes) |
| 148 | 2268x |
invisible(self) |
| 149 |
}, |
|
| 150 | ||
| 151 |
#' @description Set theme. |
|
| 152 |
#' @param theme CographTheme object or theme name. |
|
| 153 |
set_theme = function(theme) {
|
|
| 154 | 3210x |
private$.theme <- theme |
| 155 | 3210x |
invisible(self) |
| 156 |
}, |
|
| 157 | ||
| 158 |
#' @description Get nodes data frame. |
|
| 159 |
#' @return Data frame with node information. |
|
| 160 |
get_nodes = function() {
|
|
| 161 | 7468x |
private$.nodes |
| 162 |
}, |
|
| 163 | ||
| 164 |
#' @description Get edges data frame. |
|
| 165 |
#' @return Data frame with edge information. |
|
| 166 |
get_edges = function() {
|
|
| 167 | 6646x |
private$.edges |
| 168 |
}, |
|
| 169 | ||
| 170 |
#' @description Get layout coordinates. |
|
| 171 |
#' @return Data frame with x, y coordinates. |
|
| 172 |
get_layout = function() {
|
|
| 173 | 4145x |
private$.layout |
| 174 |
}, |
|
| 175 | ||
| 176 |
#' @description Get node aesthetics. |
|
| 177 |
#' @return List of node aesthetic parameters. |
|
| 178 |
get_node_aes = function() {
|
|
| 179 | 5292x |
private$.node_aes |
| 180 |
}, |
|
| 181 | ||
| 182 |
#' @description Get edge aesthetics. |
|
| 183 |
#' @return List of edge aesthetic parameters. |
|
| 184 |
get_edge_aes = function() {
|
|
| 185 | 4718x |
private$.edge_aes |
| 186 |
}, |
|
| 187 | ||
| 188 |
#' @description Get theme. |
|
| 189 |
#' @return CographTheme object. |
|
| 190 |
get_theme = function() {
|
|
| 191 | 2626x |
private$.theme |
| 192 |
}, |
|
| 193 | ||
| 194 |
#' @description Set layout info. |
|
| 195 |
#' @param info List with layout information (name, seed, etc.). |
|
| 196 |
set_layout_info = function(info) {
|
|
| 197 | 3821x |
private$.layout_info <- info |
| 198 | 3821x |
invisible(self) |
| 199 |
}, |
|
| 200 | ||
| 201 |
#' @description Get layout info. |
|
| 202 |
#' @return List with layout information. |
|
| 203 |
get_layout_info = function() {
|
|
| 204 | 3592x |
private$.layout_info |
| 205 |
}, |
|
| 206 | ||
| 207 |
#' @description Set plot parameters. |
|
| 208 |
#' @param params List of all plot parameters used. |
|
| 209 |
set_plot_params = function(params) {
|
|
| 210 | 504x |
private$.plot_params <- params |
| 211 | 504x |
invisible(self) |
| 212 |
}, |
|
| 213 | ||
| 214 |
#' @description Get plot parameters. |
|
| 215 |
#' @return List of plot parameters. |
|
| 216 |
get_plot_params = function() {
|
|
| 217 | 3591x |
private$.plot_params |
| 218 |
}, |
|
| 219 | ||
| 220 |
#' @description Print network summary. |
|
| 221 |
print = function() {
|
|
| 222 | 2x |
cat("CographNetwork\n")
|
| 223 | 2x |
cat(" Nodes:", self$n_nodes, "\n")
|
| 224 | 2x |
cat(" Edges:", self$n_edges, "\n")
|
| 225 | 2x |
cat(" Directed:", self$is_directed, "\n")
|
| 226 | 2x |
cat(" Layout:", if (is.null(private$.layout)) "none" else "set", "\n")
|
| 227 | 2x |
invisible(self) |
| 228 |
} |
|
| 229 |
), |
|
| 230 | ||
| 231 |
active = list( |
|
| 232 |
#' @field n_nodes Number of nodes in the network. |
|
| 233 |
n_nodes = function() {
|
|
| 234 | 5x |
if (is.null(private$.nodes)) 0L else nrow(private$.nodes) |
| 235 |
}, |
|
| 236 | ||
| 237 |
#' @field n_edges Number of edges in the network. |
|
| 238 |
n_edges = function() {
|
|
| 239 | 1x |
if (is.null(private$.edges)) 0L else nrow(private$.edges) |
| 240 |
}, |
|
| 241 | ||
| 242 |
#' @field is_directed Whether the network is directed. |
|
| 243 |
is_directed = function() {
|
|
| 244 | 1748x |
private$.directed |
| 245 |
}, |
|
| 246 | ||
| 247 |
#' @field has_weights Whether edges have weights. |
|
| 248 |
has_weights = function() {
|
|
| 249 | 21x |
!is.null(private$.weights) && any(private$.weights != 1) |
| 250 |
}, |
|
| 251 | ||
| 252 |
#' @field node_labels Vector of node labels. |
|
| 253 |
node_labels = function() {
|
|
| 254 | 1x |
if (is.null(private$.nodes)) NULL else private$.nodes$label |
| 255 |
} |
|
| 256 |
), |
|
| 257 | ||
| 258 |
private = list( |
|
| 259 |
.nodes = NULL, |
|
| 260 |
.edges = NULL, |
|
| 261 |
.directed = FALSE, |
|
| 262 |
.weights = NULL, |
|
| 263 |
.layout = NULL, |
|
| 264 |
.node_aes = NULL, |
|
| 265 |
.edge_aes = NULL, |
|
| 266 |
.theme = NULL, |
|
| 267 |
.layout_info = NULL, |
|
| 268 |
.plot_params = NULL |
|
| 269 |
) |
|
| 270 |
) |
|
| 271 | ||
| 272 |
#' @title Check if object is a CographNetwork |
|
| 273 |
#' @param x Object to check. |
|
| 274 |
#' @return Logical. |
|
| 275 |
#' @keywords internal |
|
| 276 |
is_cograph_network <- function(x) {
|
|
| 277 | ||
| 278 | 1622x |
inherits(x, "CographNetwork") || inherits(x, "cograph_network") |
| 279 |
} |
|
| 280 | ||
| 281 |
#' @title Create cograph_network S3 class wrapper |
|
| 282 |
#' @param network CographNetwork R6 object. |
|
| 283 |
#' @return Object with cograph_network class. |
|
| 284 |
#' @keywords internal |
|
| 285 |
as_cograph_network <- function(network) {
|
|
| 286 | 3589x |
obj <- structure( |
| 287 | 3589x |
list(network = network), |
| 288 | 3589x |
class = c("cograph_network", "list")
|
| 289 |
) |
|
| 290 |
# Add direct access to layout and plot params |
|
| 291 | 3589x |
obj$layout <- network$get_layout() |
| 292 | 3589x |
obj$layout_info <- network$get_layout_info() |
| 293 | 3589x |
obj$plot_params <- network$get_plot_params() |
| 294 | 3589x |
obj$nodes <- network$get_nodes() |
| 295 | 3589x |
obj$edges <- network$get_edges() |
| 296 | 3589x |
obj$node_aes <- network$get_node_aes() |
| 297 | 3589x |
obj$edge_aes <- network$get_edge_aes() |
| 298 | 3589x |
obj |
| 299 |
} |
|
| 300 | ||
| 301 |
# ============================================================================= |
|
| 302 |
# Getter Functions for cograph_network |
|
| 303 |
# ============================================================================= |
|
| 304 | ||
| 305 |
#' Get Nodes from Cograph Network |
|
| 306 |
#' |
|
| 307 |
#' Extracts the nodes data frame from a cograph_network object. |
|
| 308 |
#' |
|
| 309 |
#' @param x A cograph_network object. |
|
| 310 |
#' @return A data frame with columns: id, label, name, x, y (and possibly others). |
|
| 311 |
#' |
|
| 312 |
#' @seealso \code{\link{as_cograph}}, \code{\link{n_nodes}}, \code{\link{get_edges}}
|
|
| 313 |
#' |
|
| 314 |
#' @export |
|
| 315 |
#' |
|
| 316 |
#' @examples |
|
| 317 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 318 |
#' net <- as_cograph(mat) |
|
| 319 |
#' get_nodes(net) |
|
| 320 |
get_nodes <- function(x) {
|
|
| 321 | 2508x |
if (inherits(x, "cograph_network")) {
|
| 322 |
# Check for new list format first (nodes stored as list element) |
|
| 323 | 2507x |
if (!is.null(x$nodes) && is.data.frame(x$nodes)) {
|
| 324 | 2505x |
return(x$nodes) |
| 325 |
} |
|
| 326 |
# Check for old attr format |
|
| 327 | 2x |
nodes_attr <- attr(x, "nodes") |
| 328 | 2x |
if (!is.null(nodes_attr)) {
|
| 329 | 1x |
return(nodes_attr) |
| 330 |
} |
|
| 331 |
# R6 object in old wrapper |
|
| 332 | 1x |
if (!is.null(x$network) && inherits(x$network, "CographNetwork")) {
|
| 333 | 1x |
return(x$network$get_nodes()) |
| 334 |
} |
|
| 335 |
} |
|
| 336 | 1x |
stop("Cannot extract nodes from this object", call. = FALSE)
|
| 337 |
} |
|
| 338 | ||
| 339 |
#' Get Edges from Cograph Network |
|
| 340 |
#' |
|
| 341 |
#' Extracts the edges data frame from a cograph_network object. |
|
| 342 |
#' For the new format, builds a data frame from the from/to/weight vectors. |
|
| 343 |
#' |
|
| 344 |
#' @param x A cograph_network object. |
|
| 345 |
#' @return A data frame with columns: from, to, weight. |
|
| 346 |
#' |
|
| 347 |
#' @seealso \code{\link{as_cograph}}, \code{\link{n_edges}}, \code{\link{get_nodes}}
|
|
| 348 |
#' |
|
| 349 |
#' @export |
|
| 350 |
#' |
|
| 351 |
#' @examples |
|
| 352 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 353 |
#' net <- as_cograph(mat) |
|
| 354 |
#' get_edges(net) |
|
| 355 |
get_edges <- function(x) {
|
|
| 356 | 704x |
if (inherits(x, "cograph_network")) {
|
| 357 |
# Check for new list format (from/to/weight as list elements) |
|
| 358 | 703x |
if (!is.null(x$n_nodes)) {
|
| 359 |
# New format: build data frame from vectors |
|
| 360 | 41x |
if (length(x$from) > 0) {
|
| 361 | 40x |
return(data.frame( |
| 362 | 40x |
from = x$from, |
| 363 | 40x |
to = x$to, |
| 364 | 40x |
weight = x$weight, |
| 365 | 40x |
stringsAsFactors = FALSE |
| 366 |
)) |
|
| 367 |
} else {
|
|
| 368 | 1x |
return(data.frame(from = integer(0), to = integer(0), weight = numeric(0))) |
| 369 |
} |
|
| 370 |
} |
|
| 371 |
# Check for old wrapper format with edges stored directly |
|
| 372 | 662x |
if (!is.null(x$edges) && is.data.frame(x$edges)) {
|
| 373 | 661x |
return(x$edges) |
| 374 |
} |
|
| 375 |
# R6 object in old wrapper |
|
| 376 | 1x |
if (!is.null(x$network) && inherits(x$network, "CographNetwork")) {
|
| 377 | 1x |
return(x$network$get_edges()) |
| 378 |
} |
|
| 379 |
} |
|
| 380 | 1x |
stop("Cannot extract edges from this object", call. = FALSE)
|
| 381 |
} |
|
| 382 | ||
| 383 |
#' Get Labels from Cograph Network |
|
| 384 |
#' |
|
| 385 |
#' Extracts the node labels vector from a cograph_network object. |
|
| 386 |
#' |
|
| 387 |
#' @param x A cograph_network object. |
|
| 388 |
#' @return A character vector of node labels. |
|
| 389 |
#' |
|
| 390 |
#' @seealso \code{\link{as_cograph}}, \code{\link{get_nodes}}
|
|
| 391 |
#' |
|
| 392 |
#' @export |
|
| 393 |
#' |
|
| 394 |
#' @examples |
|
| 395 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 396 |
#' net <- as_cograph(mat) |
|
| 397 |
#' get_labels(net) |
|
| 398 |
get_labels <- function(x) {
|
|
| 399 | 5x |
if (inherits(x, "cograph_network")) {
|
| 400 |
# Check for new list format |
|
| 401 | 4x |
if (!is.null(x$labels)) {
|
| 402 | 2x |
return(x$labels) |
| 403 |
} |
|
| 404 |
# Check for old attr format |
|
| 405 | 2x |
labels_attr <- attr(x, "labels") |
| 406 | 2x |
if (!is.null(labels_attr)) {
|
| 407 | 1x |
return(labels_attr) |
| 408 |
} |
|
| 409 |
# Try getting from nodes |
|
| 410 | 1x |
nodes <- get_nodes(x) |
| 411 | 1x |
if (!is.null(nodes) && "label" %in% names(nodes)) {
|
| 412 | 1x |
return(nodes$label) |
| 413 |
} |
|
| 414 |
} |
|
| 415 | 1x |
stop("Cannot extract labels from this object", call. = FALSE)
|
| 416 |
} |
|
| 417 | ||
| 418 |
# ============================================================================= |
|
| 419 |
# Setter Functions for cograph_network |
|
| 420 |
# ============================================================================= |
|
| 421 | ||
| 422 |
#' Set Nodes in Cograph Network |
|
| 423 |
#' |
|
| 424 |
#' Replaces the nodes data frame in a cograph_network object. |
|
| 425 |
#' Automatically updates n_nodes and labels. |
|
| 426 |
#' |
|
| 427 |
#' @param x A cograph_network object. |
|
| 428 |
#' @param nodes_df A data frame with node information (id, label columns expected). |
|
| 429 |
#' @return The modified cograph_network object. |
|
| 430 |
#' |
|
| 431 |
#' @seealso \code{\link{as_cograph}}, \code{\link{get_nodes}}, \code{\link{set_edges}}
|
|
| 432 |
#' |
|
| 433 |
#' @export |
|
| 434 |
#' |
|
| 435 |
#' @examples |
|
| 436 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 437 |
#' net <- as_cograph(mat) |
|
| 438 |
#' new_nodes <- data.frame(id = 1:3, label = c("A", "B", "C"))
|
|
| 439 |
#' net <- set_nodes(net, new_nodes) |
|
| 440 |
#' get_labels(net) |
|
| 441 |
set_nodes <- function(x, nodes_df) {
|
|
| 442 | 5x |
if (!inherits(x, "cograph_network")) {
|
| 443 | 1x |
stop("x must be a cograph_network object", call. = FALSE)
|
| 444 |
} |
|
| 445 | 4x |
if (!is.data.frame(nodes_df)) {
|
| 446 | 1x |
stop("nodes_df must be a data frame", call. = FALSE)
|
| 447 |
} |
|
| 448 | ||
| 449 |
# Ensure required columns |
|
| 450 | 3x |
if (!"id" %in% names(nodes_df)) {
|
| 451 | 1x |
nodes_df$id <- seq_len(nrow(nodes_df)) |
| 452 |
} |
|
| 453 | 3x |
if (!"label" %in% names(nodes_df)) {
|
| 454 | 1x |
nodes_df$label <- as.character(nodes_df$id) |
| 455 |
} |
|
| 456 | ||
| 457 |
# Update the network |
|
| 458 | 3x |
x$nodes <- nodes_df |
| 459 | 3x |
x$n_nodes <- nrow(nodes_df) |
| 460 | 3x |
x$labels <- nodes_df$label |
| 461 | ||
| 462 | 3x |
x |
| 463 |
} |
|
| 464 | ||
| 465 |
#' Set Edges in Cograph Network |
|
| 466 |
#' |
|
| 467 |
#' Replaces the edges in a cograph_network object. |
|
| 468 |
#' Expects a data frame with from, to, and optionally weight columns. |
|
| 469 |
#' Updates the from, to, weight vectors and n_edges. |
|
| 470 |
#' |
|
| 471 |
#' @param x A cograph_network object. |
|
| 472 |
#' @param edges_df A data frame with columns: from, to, and optionally weight. |
|
| 473 |
#' @return The modified cograph_network object. |
|
| 474 |
#' |
|
| 475 |
#' @seealso \code{\link{as_cograph}}, \code{\link{get_edges}}, \code{\link{set_nodes}}
|
|
| 476 |
#' |
|
| 477 |
#' @export |
|
| 478 |
#' |
|
| 479 |
#' @examples |
|
| 480 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 481 |
#' net <- as_cograph(mat) |
|
| 482 |
#' new_edges <- data.frame(from = c(1, 2), to = c(2, 3), weight = c(0.5, 0.8)) |
|
| 483 |
#' net <- set_edges(net, new_edges) |
|
| 484 |
#' get_edges(net) |
|
| 485 |
set_edges <- function(x, edges_df) {
|
|
| 486 | 5x |
if (!inherits(x, "cograph_network")) {
|
| 487 | 1x |
stop("x must be a cograph_network object", call. = FALSE)
|
| 488 |
} |
|
| 489 | 4x |
if (!is.data.frame(edges_df)) {
|
| 490 | 1x |
stop("edges_df must be a data frame", call. = FALSE)
|
| 491 |
} |
|
| 492 | ||
| 493 |
# Ensure required columns |
|
| 494 | 3x |
if (!all(c("from", "to") %in% names(edges_df))) {
|
| 495 | 1x |
stop("edges_df must have 'from' and 'to' columns", call. = FALSE)
|
| 496 |
} |
|
| 497 | 2x |
if (!"weight" %in% names(edges_df)) {
|
| 498 | 1x |
edges_df$weight <- rep(1, nrow(edges_df)) |
| 499 |
} |
|
| 500 | ||
| 501 |
# Update the network |
|
| 502 | 2x |
x$from <- as.integer(edges_df$from) |
| 503 | 2x |
x$to <- as.integer(edges_df$to) |
| 504 | 2x |
x$weight <- as.numeric(edges_df$weight) |
| 505 | 2x |
x$n_edges <- nrow(edges_df) |
| 506 | ||
| 507 | 2x |
x |
| 508 |
} |
|
| 509 | ||
| 510 |
#' Set Layout in Cograph Network |
|
| 511 |
#' |
|
| 512 |
#' Sets the layout coordinates in a cograph_network object. |
|
| 513 |
#' Updates the x and y columns in the nodes data frame. |
|
| 514 |
#' |
|
| 515 |
#' @param x A cograph_network object. |
|
| 516 |
#' @param layout_df A data frame with x and y columns, or a matrix with 2 columns. |
|
| 517 |
#' @return The modified cograph_network object. |
|
| 518 |
#' |
|
| 519 |
#' @seealso \code{\link{as_cograph}}, \code{\link{get_nodes}}, \code{\link{sn_layout}}
|
|
| 520 |
#' |
|
| 521 |
#' @export |
|
| 522 |
#' |
|
| 523 |
#' @examples |
|
| 524 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 525 |
#' net <- as_cograph(mat) |
|
| 526 |
#' layout <- data.frame(x = c(0, 1, 0.5), y = c(0, 0, 1)) |
|
| 527 |
#' net <- set_layout(net, layout) |
|
| 528 |
#' get_nodes(net) |
|
| 529 |
set_layout <- function(x, layout_df) {
|
|
| 530 | 6x |
if (!inherits(x, "cograph_network")) {
|
| 531 | 1x |
stop("x must be a cograph_network object", call. = FALSE)
|
| 532 |
} |
|
| 533 | ||
| 534 |
# Convert matrix to data frame |
|
| 535 | 5x |
if (is.matrix(layout_df)) {
|
| 536 | 1x |
layout_df <- as.data.frame(layout_df) |
| 537 | 1x |
if (ncol(layout_df) >= 2) {
|
| 538 | 1x |
names(layout_df)[1:2] <- c("x", "y")
|
| 539 |
} |
|
| 540 |
} |
|
| 541 | ||
| 542 | 5x |
if (!is.data.frame(layout_df) || !all(c("x", "y") %in% names(layout_df))) {
|
| 543 | 1x |
stop("layout_df must have 'x' and 'y' columns", call. = FALSE)
|
| 544 |
} |
|
| 545 | ||
| 546 |
# Update nodes with layout coordinates |
|
| 547 | 4x |
nodes <- get_nodes(x) |
| 548 | 4x |
if (nrow(layout_df) != nrow(nodes)) {
|
| 549 | 1x |
stop("layout_df must have the same number of rows as nodes", call. = FALSE)
|
| 550 |
} |
|
| 551 | ||
| 552 | 3x |
nodes$x <- layout_df$x |
| 553 | 3x |
nodes$y <- layout_df$y |
| 554 | 3x |
x$nodes <- nodes |
| 555 | 3x |
x$layout <- layout_df |
| 556 | ||
| 557 | 3x |
x |
| 558 |
} |
|
| 559 | ||
| 560 |
# ============================================================================= |
|
| 561 |
# New Lightweight cograph_network Format |
|
| 562 |
# ============================================================================= |
|
| 563 | ||
| 564 |
#' Convert to Cograph Network |
|
| 565 |
#' |
|
| 566 |
#' Creates a lightweight cograph_network object from various network inputs. |
|
| 567 |
#' The resulting object is a named list with all data accessible via \code{$}.
|
|
| 568 |
#' |
|
| 569 |
#' @param x Network input. Can be: |
|
| 570 |
#' - A square numeric matrix (adjacency/weight matrix) |
|
| 571 |
#' - A data frame with edge list (from, to, optional weight columns) |
|
| 572 |
#' - An igraph object |
|
| 573 |
#' - A statnet network object |
|
| 574 |
#' - A qgraph object |
|
| 575 |
#' - A tna object |
|
| 576 |
#' - An existing cograph_network object (returned as-is) |
|
| 577 |
#' @param directed Logical. Force directed interpretation. NULL for auto-detect. |
|
| 578 |
#' @param ... Additional arguments (currently unused). |
|
| 579 |
#' |
|
| 580 |
#' @return A cograph_network object: a named list with components: |
|
| 581 |
#' \describe{
|
|
| 582 |
#' \item{\code{from}}{Integer vector of source node indices}
|
|
| 583 |
#' \item{\code{to}}{Integer vector of target node indices}
|
|
| 584 |
#' \item{\code{weight}}{Numeric vector of edge weights}
|
|
| 585 |
#' \item{\code{nodes}}{Data frame with id, label, (x, y if layout applied)}
|
|
| 586 |
#' \item{\code{directed}}{Logical indicating if network is directed}
|
|
| 587 |
#' \item{\code{n_nodes}}{Integer count of nodes}
|
|
| 588 |
#' \item{\code{n_edges}}{Integer count of edges}
|
|
| 589 |
#' \item{\code{labels}}{Character vector of node labels}
|
|
| 590 |
#' \item{\code{source}}{Character indicating input type}
|
|
| 591 |
#' \item{\code{layout}}{Layout coordinates (NULL until computed)}
|
|
| 592 |
#' \item{\code{layout_info}}{Layout algorithm info (NULL until computed)}
|
|
| 593 |
#' } |
|
| 594 |
#' |
|
| 595 |
#' @details |
|
| 596 |
#' The cograph_network format is designed to be: |
|
| 597 |
#' - Simple: All data accessible via \code{net$from}, \code{net$to}, \code{net$weight}, etc.
|
|
| 598 |
#' - Modern: Uses named list elements instead of attributes for clean \code{$} access
|
|
| 599 |
#' - Compatible: Works seamlessly with splot() and other cograph functions |
|
| 600 |
#' |
|
| 601 |
#' Use getter functions for programmatic access: |
|
| 602 |
#' \code{\link{get_nodes}}, \code{\link{get_edges}}, \code{\link{get_labels}}
|
|
| 603 |
#' |
|
| 604 |
#' Use setter functions to modify: |
|
| 605 |
#' \code{\link{set_nodes}}, \code{\link{set_edges}}, \code{\link{set_layout}}
|
|
| 606 |
#' |
|
| 607 |
#' @seealso |
|
| 608 |
#' \code{\link{get_nodes}} to extract the nodes data frame,
|
|
| 609 |
#' \code{\link{get_edges}} to extract edges as a data frame,
|
|
| 610 |
#' \code{\link{n_nodes}} and \code{\link{n_edges}} for counts,
|
|
| 611 |
#' \code{\link{is_directed}} to check directedness,
|
|
| 612 |
#' \code{\link{splot}} for plotting
|
|
| 613 |
#' |
|
| 614 |
#' @export |
|
| 615 |
#' |
|
| 616 |
#' @examples |
|
| 617 |
#' # From adjacency matrix |
|
| 618 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 619 |
#' net <- as_cograph(mat) |
|
| 620 |
#' |
|
| 621 |
#' # Direct $ access to all data |
|
| 622 |
#' net$from # edge sources |
|
| 623 |
#' net$to # edge targets |
|
| 624 |
#' net$weight # edge weights |
|
| 625 |
#' net$nodes # nodes data frame |
|
| 626 |
#' net$directed # TRUE/FALSE |
|
| 627 |
#' net$n_nodes # 3 |
|
| 628 |
#' net$n_edges # 3 |
|
| 629 |
#' |
|
| 630 |
#' # Getter functions (recommended for programmatic use) |
|
| 631 |
#' get_nodes(net) # nodes data frame |
|
| 632 |
#' get_edges(net) # edges data frame (from, to, weight) |
|
| 633 |
#' get_labels(net) # character vector of labels |
|
| 634 |
#' n_nodes(net) # 3 |
|
| 635 |
#' n_edges(net) # 3 |
|
| 636 |
#' is_directed(net) # FALSE (symmetric matrix) |
|
| 637 |
#' |
|
| 638 |
#' # Setter functions |
|
| 639 |
#' net <- set_nodes(net, data.frame(id = 1:3, label = c("A", "B", "C")))
|
|
| 640 |
#' net <- set_edges(net, data.frame(from = c(1,2), to = c(2,3), weight = c(0.5, 0.8))) |
|
| 641 |
#' net <- set_layout(net, data.frame(x = c(0, 1, 0.5), y = c(0, 0, 1))) |
|
| 642 |
#' |
|
| 643 |
#' # Plot it |
|
| 644 |
#' splot(net) |
|
| 645 |
#' |
|
| 646 |
#' # From igraph (if installed) |
|
| 647 |
#' \dontrun{
|
|
| 648 |
#' library(igraph) |
|
| 649 |
#' g <- make_ring(10) |
|
| 650 |
#' net <- as_cograph(g) |
|
| 651 |
#' splot(net) |
|
| 652 |
#' } |
|
| 653 |
as_cograph <- function(x, directed = NULL, ...) {
|
|
| 654 |
# Return as-is if already a cograph_network |
|
| 655 | ||
| 656 | 70x |
if (inherits(x, "cograph_network")) {
|
| 657 | 1x |
return(x) |
| 658 |
} |
|
| 659 | ||
| 660 |
# Parse the input |
|
| 661 | 69x |
parsed <- parse_input(x, directed = directed) |
| 662 | ||
| 663 |
# Determine source type |
|
| 664 | 68x |
source_type <- if (is.matrix(x)) {
|
| 665 | 60x |
"matrix" |
| 666 | 68x |
} else if (is.data.frame(x)) {
|
| 667 | 4x |
"edgelist" |
| 668 | 68x |
} else if (inherits(x, "igraph")) {
|
| 669 | 1x |
"igraph" |
| 670 | 68x |
} else if (inherits(x, "network")) {
|
| 671 | 1x |
"network" |
| 672 | 68x |
} else if (inherits(x, "qgraph")) {
|
| 673 | 1x |
"qgraph" |
| 674 | 68x |
} else if (inherits(x, "tna")) {
|
| 675 | 1x |
"tna" |
| 676 |
} else {
|
|
| 677 | ! |
"unknown" |
| 678 |
} |
|
| 679 | ||
| 680 |
# Extract from/to/weight from edges data frame |
|
| 681 | 68x |
edges <- parsed$edges |
| 682 | 68x |
if (!is.null(edges) && nrow(edges) > 0) {
|
| 683 | 66x |
from_vec <- as.integer(edges$from) |
| 684 | 66x |
to_vec <- as.integer(edges$to) |
| 685 | 66x |
weight_vec <- if (!is.null(edges$weight)) as.numeric(edges$weight) else rep(1, nrow(edges)) |
| 686 |
} else {
|
|
| 687 | 2x |
from_vec <- integer(0) |
| 688 | 2x |
to_vec <- integer(0) |
| 689 | 2x |
weight_vec <- numeric(0) |
| 690 |
} |
|
| 691 | ||
| 692 |
# Get nodes data frame |
|
| 693 | ||
| 694 | 68x |
nodes_df <- parsed$nodes |
| 695 | ||
| 696 |
# Create the network object with all data as named list elements |
|
| 697 | 68x |
net <- list( |
| 698 |
# Core edge data |
|
| 699 | 68x |
from = from_vec, |
| 700 | 68x |
to = to_vec, |
| 701 | 68x |
weight = weight_vec, |
| 702 | ||
| 703 |
# Metadata as list elements (not attributes) |
|
| 704 | 68x |
nodes = nodes_df, |
| 705 | 68x |
directed = parsed$directed, |
| 706 | 68x |
n_nodes = nrow(nodes_df), |
| 707 | 68x |
n_edges = length(from_vec), |
| 708 | 68x |
labels = nodes_df$label, |
| 709 | 68x |
source = source_type, |
| 710 | ||
| 711 |
# Optional elements (NULL if not set) |
|
| 712 | 68x |
layout = NULL, |
| 713 | 68x |
layout_info = NULL, |
| 714 | 68x |
layers = NULL, |
| 715 | 68x |
clusters = NULL, |
| 716 | 68x |
groups = NULL |
| 717 |
) |
|
| 718 | ||
| 719 |
# Set S3 class |
|
| 720 | 68x |
class(net) <- c("cograph_network", "list")
|
| 721 | ||
| 722 | 68x |
net |
| 723 |
} |
|
| 724 | ||
| 725 |
#' Get Nodes from Cograph Network (Deprecated) |
|
| 726 |
#' |
|
| 727 |
#' Extracts the nodes data frame from a cograph_network object. |
|
| 728 |
#' \strong{Deprecated}: Use \code{\link{get_nodes}} instead.
|
|
| 729 |
#' |
|
| 730 |
#' @param x A cograph_network object. |
|
| 731 |
#' @return A data frame with columns: id, label, name, x, y (and possibly others). |
|
| 732 |
#' |
|
| 733 |
#' @seealso \code{\link{get_nodes}}, \code{\link{as_cograph}}, \code{\link{n_nodes}}
|
|
| 734 |
#' @keywords internal |
|
| 735 |
#' @export |
|
| 736 |
#' |
|
| 737 |
#' @examples |
|
| 738 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 739 |
#' net <- as_cograph(mat) |
|
| 740 |
#' nodes(net) # Deprecated, use get_nodes(net) instead |
|
| 741 |
nodes <- function(x) {
|
|
| 742 |
# Soft deprecation warning |
|
| 743 |
# .Deprecated("get_nodes")
|
|
| 744 | 1x |
get_nodes(x) |
| 745 |
} |
|
| 746 | ||
| 747 |
#' Check if Network is Directed |
|
| 748 |
#' |
|
| 749 |
#' Checks whether a cograph_network is directed. |
|
| 750 |
#' @keywords internal |
|
| 751 |
#' @param x A cograph_network object. |
|
| 752 |
#' @return Logical: TRUE if directed, FALSE if undirected. |
|
| 753 |
#' |
|
| 754 |
#' @seealso \code{\link{as_cograph}}
|
|
| 755 |
#' |
|
| 756 |
#' @export |
|
| 757 |
#' |
|
| 758 |
#' @examples |
|
| 759 |
#' # Symmetric matrix -> undirected |
|
| 760 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 761 |
#' net <- as_cograph(mat) |
|
| 762 |
#' is_directed(net) # FALSE |
|
| 763 |
#' |
|
| 764 |
#' # Asymmetric matrix -> directed |
|
| 765 |
#' mat2 <- matrix(c(0, 1, 0, 0, 0, 1, 0, 0, 0), nrow = 3) |
|
| 766 |
#' net2 <- as_cograph(mat2) |
|
| 767 |
#' is_directed(net2) # TRUE |
|
| 768 |
is_directed <- function(x) {
|
|
| 769 | 702x |
if (inherits(x, "cograph_network")) {
|
| 770 |
# Check for new list format first (directed stored as list element) |
|
| 771 | 701x |
if (!is.null(x$directed)) {
|
| 772 | 45x |
return(x$directed) |
| 773 |
} |
|
| 774 |
# Check for old attr format |
|
| 775 | 656x |
dir_attr <- attr(x, "directed") |
| 776 | 656x |
if (!is.null(dir_attr)) {
|
| 777 | 1x |
return(dir_attr) |
| 778 |
} |
|
| 779 |
# R6 object in old wrapper |
|
| 780 | 655x |
if (!is.null(x$network) && inherits(x$network, "CographNetwork")) {
|
| 781 | 655x |
return(x$network$is_directed) |
| 782 |
} |
|
| 783 |
} |
|
| 784 | 1x |
stop("Cannot determine directedness for this object", call. = FALSE)
|
| 785 |
} |
|
| 786 | ||
| 787 |
#' Get Number of Nodes |
|
| 788 |
#' |
|
| 789 |
#' Returns the number of nodes in a cograph_network. |
|
| 790 |
#' |
|
| 791 |
#' @param x A cograph_network object. |
|
| 792 |
#' @return Integer: number of nodes. |
|
| 793 |
#' |
|
| 794 |
#' @seealso \code{\link{as_cograph}}, \code{\link{n_edges}}, \code{\link{get_nodes}}
|
|
| 795 |
#' |
|
| 796 |
#' @export |
|
| 797 |
#' |
|
| 798 |
#' @examples |
|
| 799 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 800 |
#' net <- as_cograph(mat) |
|
| 801 |
#' n_nodes(net) # 3 |
|
| 802 |
n_nodes <- function(x) {
|
|
| 803 | 4x |
if (inherits(x, "cograph_network")) {
|
| 804 |
# Check for new list format first (n_nodes stored as list element) |
|
| 805 | 3x |
if (!is.null(x$n_nodes)) {
|
| 806 | 1x |
return(x$n_nodes) |
| 807 |
} |
|
| 808 |
# Check for old attr format |
|
| 809 | 2x |
n_attr <- attr(x, "n_nodes") |
| 810 | 2x |
if (!is.null(n_attr)) {
|
| 811 | 1x |
return(n_attr) |
| 812 |
} |
|
| 813 |
# R6 object in old wrapper |
|
| 814 | 1x |
if (!is.null(x$network) && inherits(x$network, "CographNetwork")) {
|
| 815 | 1x |
return(x$network$n_nodes) |
| 816 |
} |
|
| 817 |
} |
|
| 818 | 1x |
stop("Cannot count nodes for this object", call. = FALSE)
|
| 819 |
} |
|
| 820 | ||
| 821 |
#' Get Number of Edges |
|
| 822 |
#' |
|
| 823 |
#' Returns the number of edges in a cograph_network. |
|
| 824 |
#' |
|
| 825 |
#' @param x A cograph_network object. |
|
| 826 |
#' @return Integer: number of edges. |
|
| 827 |
#' |
|
| 828 |
#' @seealso \code{\link{as_cograph}}, \code{\link{n_nodes}}
|
|
| 829 |
#' |
|
| 830 |
#' @export |
|
| 831 |
#' |
|
| 832 |
#' @examples |
|
| 833 |
#' mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 834 |
#' net <- as_cograph(mat) |
|
| 835 |
#' n_edges(net) # 3 |
|
| 836 |
n_edges <- function(x) {
|
|
| 837 | 4x |
if (inherits(x, "cograph_network")) {
|
| 838 |
# Check for new list format first (n_edges stored as list element) |
|
| 839 | 3x |
if (!is.null(x$n_edges)) {
|
| 840 | 1x |
return(x$n_edges) |
| 841 |
} |
|
| 842 |
# Check for old attr format |
|
| 843 | 2x |
n_attr <- attr(x, "n_edges") |
| 844 | 2x |
if (!is.null(n_attr)) {
|
| 845 | 1x |
return(n_attr) |
| 846 |
} |
|
| 847 |
# R6 object in old wrapper |
|
| 848 | 1x |
if (!is.null(x$network) && inherits(x$network, "CographNetwork")) {
|
| 849 | 1x |
return(x$network$n_edges) |
| 850 |
} |
|
| 851 |
} |
|
| 852 | 1x |
stop("Cannot count edges for this object", call. = FALSE)
|
| 853 |
} |
|
| 854 |
| 1 |
#' @title Global Registries for cograph |
|
| 2 |
#' @description Internal registries for shapes, layouts, and themes. |
|
| 3 |
#' @name globals |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
# Package environment for storing registries |
|
| 8 |
.cograph_env <- new.env(parent = emptyenv()) |
|
| 9 | ||
| 10 |
#' Initialize Global Registries |
|
| 11 |
#' @keywords internal |
|
| 12 |
init_registries <- function() {
|
|
| 13 | 2x |
.cograph_env$shapes <- list() |
| 14 | 2x |
.cograph_env$layouts <- list() |
| 15 | 2x |
.cograph_env$themes <- list() |
| 16 | 2x |
.cograph_env$palettes <- list() |
| 17 |
} |
|
| 18 | ||
| 19 |
# ============================================================================ |
|
| 20 |
# Shape Registry |
|
| 21 |
# ============================================================================ |
|
| 22 | ||
| 23 |
#' Register a Custom Shape |
|
| 24 |
#' |
|
| 25 |
#' Register a new shape that can be used for node rendering. |
|
| 26 |
#' |
|
| 27 |
#' @param name Character. Name of the shape. |
|
| 28 |
#' @param draw_fn Function. A function that draws the shape. Should accept |
|
| 29 |
#' parameters: x, y, size, fill, border_color, border_width, ... |
|
| 30 |
#' |
|
| 31 |
#' @return Invisible NULL. |
|
| 32 |
#' @export |
|
| 33 |
#' |
|
| 34 |
#' @examples |
|
| 35 |
#' # Register a custom hexagon shape |
|
| 36 |
#' register_shape("hexagon", function(x, y, size, fill, border_color, border_width, ...) {
|
|
| 37 |
#' angles <- seq(0, 2 * pi, length.out = 7) |
|
| 38 |
#' grid::polygonGrob( |
|
| 39 |
#' x = x + size * cos(angles), |
|
| 40 |
#' y = y + size * sin(angles), |
|
| 41 |
#' gp = grid::gpar(fill = fill, col = border_color, lwd = border_width) |
|
| 42 |
#' ) |
|
| 43 |
#' }) |
|
| 44 |
register_shape <- function(name, draw_fn) {
|
|
| 45 | 91x |
if (!is.function(draw_fn)) {
|
| 46 | 3x |
stop("draw_fn must be a function", call. = FALSE)
|
| 47 |
} |
|
| 48 | 88x |
.cograph_env$shapes[[name]] <- draw_fn |
| 49 | 88x |
invisible(NULL) |
| 50 |
} |
|
| 51 | ||
| 52 |
#' Get a Registered Shape |
|
| 53 |
#' |
|
| 54 |
#' @param name Character. Name of the shape. |
|
| 55 |
#' @return The shape drawing function, or NULL if not found. |
|
| 56 |
#' @export |
|
| 57 |
#' @examples |
|
| 58 |
#' get_shape("circle")
|
|
| 59 |
get_shape <- function(name) {
|
|
| 60 | ||
| 61 | 2029x |
.cograph_env$shapes[[name]] |
| 62 |
} |
|
| 63 | ||
| 64 |
#' List Available Shapes |
|
| 65 |
#' |
|
| 66 |
#' @return Character vector of registered shape names. |
|
| 67 |
#' @export |
|
| 68 |
#' @examples |
|
| 69 |
#' list_shapes() |
|
| 70 |
list_shapes <- function() {
|
|
| 71 | 17x |
names(.cograph_env$shapes) |
| 72 |
} |
|
| 73 | ||
| 74 |
# ============================================================================ |
|
| 75 |
# Layout Registry |
|
| 76 |
# ============================================================================ |
|
| 77 | ||
| 78 |
#' Register a Custom Layout |
|
| 79 |
#' |
|
| 80 |
#' Register a new layout algorithm that can be used for network visualization. |
|
| 81 |
#' |
|
| 82 |
#' @param name Character. Name of the layout. |
|
| 83 |
#' @param layout_fn Function. A function that computes node positions. |
|
| 84 |
#' Should accept a CographNetwork object and return a matrix with x, y columns. |
|
| 85 |
#' |
|
| 86 |
#' @return Invisible NULL. |
|
| 87 |
#' @export |
|
| 88 |
#' |
|
| 89 |
#' @examples |
|
| 90 |
#' # Register a simple random layout |
|
| 91 |
#' register_layout("random", function(network, ...) {
|
|
| 92 |
#' n <- network$n_nodes |
|
| 93 |
#' cbind(x = runif(n), y = runif(n)) |
|
| 94 |
#' }) |
|
| 95 |
register_layout <- function(name, layout_fn) {
|
|
| 96 | 35x |
if (!is.function(layout_fn)) {
|
| 97 | 2x |
stop("layout_fn must be a function", call. = FALSE)
|
| 98 |
} |
|
| 99 | 33x |
.cograph_env$layouts[[name]] <- layout_fn |
| 100 | 33x |
invisible(NULL) |
| 101 |
} |
|
| 102 | ||
| 103 |
#' Get a Registered Layout |
|
| 104 |
#' |
|
| 105 |
#' @param name Character. Name of the layout. |
|
| 106 |
#' @return The layout function, or NULL if not found. |
|
| 107 |
#' @export |
|
| 108 |
#' @examples |
|
| 109 |
#' get_layout("circle")
|
|
| 110 |
get_layout <- function(name) {
|
|
| 111 | 1676x |
.cograph_env$layouts[[name]] |
| 112 |
} |
|
| 113 | ||
| 114 |
#' List Available Layouts |
|
| 115 |
#' |
|
| 116 |
#' @return Character vector of registered layout names. |
|
| 117 |
#' @export |
|
| 118 |
#' @examples |
|
| 119 |
#' list_layouts() |
|
| 120 |
list_layouts <- function() {
|
|
| 121 | 22x |
names(.cograph_env$layouts) |
| 122 |
} |
|
| 123 | ||
| 124 |
# ============================================================================ |
|
| 125 |
# Theme Registry |
|
| 126 |
# ============================================================================ |
|
| 127 | ||
| 128 |
#' Register a Custom Theme |
|
| 129 |
#' |
|
| 130 |
#' Register a new theme for network visualization. |
|
| 131 |
#' |
|
| 132 |
#' @param name Character. Name of the theme. |
|
| 133 |
#' @param theme A CographTheme object or a list of theme parameters. |
|
| 134 |
#' |
|
| 135 |
#' @return Invisible NULL. |
|
| 136 |
#' @export |
|
| 137 |
#' |
|
| 138 |
#' @examples |
|
| 139 |
#' # Register a custom theme |
|
| 140 |
#' register_theme("custom", list(
|
|
| 141 |
#' background = "white", |
|
| 142 |
#' node_fill = "steelblue", |
|
| 143 |
#' node_border = "navy", |
|
| 144 |
#' edge_color = "gray50" |
|
| 145 |
#' )) |
|
| 146 |
register_theme <- function(name, theme) {
|
|
| 147 | 27x |
.cograph_env$themes[[name]] <- theme |
| 148 | 27x |
invisible(NULL) |
| 149 |
} |
|
| 150 | ||
| 151 |
#' Get a Registered Theme |
|
| 152 |
#' |
|
| 153 |
#' @param name Character. Name of the theme. |
|
| 154 |
#' @return The theme object, or NULL if not found. |
|
| 155 |
#' @export |
|
| 156 |
#' @examples |
|
| 157 |
#' get_theme("classic")
|
|
| 158 |
get_theme <- function(name) {
|
|
| 159 | ||
| 160 | 1772x |
.cograph_env$themes[[name]] |
| 161 |
} |
|
| 162 | ||
| 163 |
#' List Available Themes |
|
| 164 |
#' |
|
| 165 |
#' @return Character vector of registered theme names. |
|
| 166 |
#' @export |
|
| 167 |
#' @examples |
|
| 168 |
#' list_themes() |
|
| 169 |
list_themes <- function() {
|
|
| 170 | 19x |
names(.cograph_env$themes) |
| 171 |
} |
|
| 172 | ||
| 173 |
# ============================================================================ |
|
| 174 |
# Palette Registry |
|
| 175 |
# ============================================================================ |
|
| 176 | ||
| 177 |
#' @keywords internal |
|
| 178 |
register_palette <- function(name, palette) {
|
|
| 179 | 18x |
.cograph_env$palettes[[name]] <- palette |
| 180 | 18x |
invisible(NULL) |
| 181 |
} |
|
| 182 | ||
| 183 |
#' @keywords internal |
|
| 184 |
get_palette <- function(name) {
|
|
| 185 | 34x |
.cograph_env$palettes[[name]] |
| 186 |
} |
|
| 187 | ||
| 188 |
#' List Available Color Palettes |
|
| 189 |
#' |
|
| 190 |
#' Returns the names of all registered color palettes. |
|
| 191 |
#' |
|
| 192 |
#' @return Character vector of palette names. |
|
| 193 |
#' @export |
|
| 194 |
#' @examples |
|
| 195 |
#' list_palettes() |
|
| 196 |
list_palettes <- function() {
|
|
| 197 | 7x |
names(.cograph_env$palettes) |
| 198 |
} |
| 1 |
#' @title CographLayout R6 Class |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description |
|
| 4 |
#' Class for managing layout algorithms and computing node positions. |
|
| 5 |
#' |
|
| 6 |
#' @export |
|
| 7 |
#' @examples |
|
| 8 |
#' # Create a circular layout |
|
| 9 |
#' layout <- CographLayout$new("circle")
|
|
| 10 |
#' |
|
| 11 |
#' # Apply to network |
|
| 12 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 13 |
#' net <- CographNetwork$new(adj) |
|
| 14 |
#' coords <- layout$compute(net) |
|
| 15 |
CographLayout <- R6::R6Class( |
|
| 16 | ||
| 17 |
"CographLayout", |
|
| 18 |
public = list( |
|
| 19 |
#' @description Create a new CographLayout object. |
|
| 20 |
#' @param type Layout type (e.g., "circle", "spring", "groups"). |
|
| 21 |
#' @param ... Additional parameters for the layout algorithm. |
|
| 22 |
#' @return A new CographLayout object. |
|
| 23 |
initialize = function(type = "circle", ...) {
|
|
| 24 | 1636x |
private$.type <- type |
| 25 | 1636x |
private$.params <- list(...) |
| 26 | 1636x |
invisible(self) |
| 27 |
}, |
|
| 28 | ||
| 29 |
#' @description Compute layout coordinates for a network. |
|
| 30 |
#' @param network A CographNetwork object. |
|
| 31 |
#' @param ... Additional parameters passed to the layout function. |
|
| 32 |
#' @return Data frame with x, y coordinates. |
|
| 33 |
compute = function(network, ...) {
|
|
| 34 | 1618x |
if (!is_cograph_network(network) && !inherits(network, "CographNetwork")) {
|
| 35 | 1x |
stop("network must be a CographNetwork object", call. = FALSE)
|
| 36 |
} |
|
| 37 | ||
| 38 |
# Handle custom coordinates |
|
| 39 | 1617x |
if (private$.type == "custom") {
|
| 40 | 3x |
coords <- private$.params$coords |
| 41 | 3x |
if (is.null(coords)) {
|
| 42 | 1x |
stop("Custom layout requires 'coords' parameter", call. = FALSE)
|
| 43 |
} |
|
| 44 | 2x |
return(self$normalize_coords(coords)) |
| 45 |
} |
|
| 46 | ||
| 47 |
# Get layout function from registry |
|
| 48 | 1614x |
layout_fn <- get_layout(private$.type) |
| 49 | 1614x |
if (is.null(layout_fn)) {
|
| 50 | 2x |
stop("Unknown layout type: ", private$.type, call. = FALSE)
|
| 51 |
} |
|
| 52 | ||
| 53 |
# Merge parameters |
|
| 54 | 1612x |
params <- utils::modifyList(private$.params, list(...)) |
| 55 | ||
| 56 |
# Compute coordinates |
|
| 57 | 1612x |
coords <- do.call(layout_fn, c(list(network = network), params)) |
| 58 | ||
| 59 |
# Normalize to 0-1 range |
|
| 60 | 1612x |
self$normalize_coords(coords) |
| 61 |
}, |
|
| 62 | ||
| 63 |
#' @description Normalize coordinates to 0-1 range with padding. |
|
| 64 |
#' @param coords Matrix or data frame with x, y columns. |
|
| 65 |
#' @param padding Numeric. Padding around edges (default 0.1). |
|
| 66 |
#' @return Normalized coordinates. |
|
| 67 |
normalize_coords = function(coords, padding = 0.1) {
|
|
| 68 | 1622x |
if (is.matrix(coords)) {
|
| 69 | 2x |
coords <- as.data.frame(coords) |
| 70 |
} |
|
| 71 | 1622x |
if (!all(c("x", "y") %in% names(coords))) {
|
| 72 | 1x |
names(coords)[1:2] <- c("x", "y")
|
| 73 |
} |
|
| 74 | ||
| 75 |
# Normalize to [padding, 1-padding] using uniform scaling to preserve aspect ratio |
|
| 76 | 1622x |
x_range <- range(coords$x, na.rm = TRUE) |
| 77 | 1622x |
y_range <- range(coords$y, na.rm = TRUE) |
| 78 | ||
| 79 | 1622x |
max_spread <- max(diff(x_range), diff(y_range)) |
| 80 | ||
| 81 | 1622x |
if (max_spread > 0) {
|
| 82 | 1602x |
scale <- (1 - 2 * padding) / max_spread |
| 83 | 1602x |
x_center <- mean(x_range) |
| 84 | 1602x |
y_center <- mean(y_range) |
| 85 | 1602x |
coords$x <- 0.5 + (coords$x - x_center) * scale |
| 86 | 1602x |
coords$y <- 0.5 + (coords$y - y_center) * scale |
| 87 |
} else {
|
|
| 88 | 20x |
coords$x <- 0.5 |
| 89 | 20x |
coords$y <- 0.5 |
| 90 |
} |
|
| 91 | ||
| 92 | 1622x |
coords |
| 93 |
}, |
|
| 94 | ||
| 95 |
#' @description Get layout type. |
|
| 96 |
#' @return Character string. |
|
| 97 |
get_type = function() {
|
|
| 98 | 3x |
private$.type |
| 99 |
}, |
|
| 100 | ||
| 101 |
#' @description Get layout parameters. |
|
| 102 |
#' @return List of parameters. |
|
| 103 |
get_params = function() {
|
|
| 104 | 3x |
private$.params |
| 105 |
}, |
|
| 106 | ||
| 107 |
#' @description Print layout summary. |
|
| 108 |
print = function() {
|
|
| 109 | 7x |
cat("CographLayout\n")
|
| 110 | 7x |
cat(" Type:", private$.type, "\n")
|
| 111 | 7x |
if (length(private$.params) > 0) {
|
| 112 | 5x |
cat(" Parameters:\n")
|
| 113 | 5x |
for (nm in names(private$.params)) {
|
| 114 | 7x |
val <- private$.params[[nm]] |
| 115 | 7x |
if (length(val) > 3) {
|
| 116 | 1x |
val <- paste0(paste(val[1:3], collapse = ", "), ", ...") |
| 117 |
} |
|
| 118 | 7x |
cat(" ", nm, ":", val, "\n")
|
| 119 |
} |
|
| 120 |
} |
|
| 121 | 7x |
invisible(self) |
| 122 |
} |
|
| 123 |
), |
|
| 124 | ||
| 125 |
private = list( |
|
| 126 |
.type = NULL, |
|
| 127 |
.params = NULL |
|
| 128 |
) |
|
| 129 |
) |
| 1 |
#' @title CographTheme R6 Class |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description |
|
| 4 |
#' Class for managing visual themes for network plots. |
|
| 5 |
#' |
|
| 6 |
#' @export |
|
| 7 |
#' @examples |
|
| 8 |
#' # Create a custom theme |
|
| 9 |
#' theme <- CographTheme$new( |
|
| 10 |
#' background = "white", |
|
| 11 |
#' node_fill = "steelblue", |
|
| 12 |
#' edge_color = "gray60" |
|
| 13 |
#' ) |
|
| 14 |
CographTheme <- R6::R6Class( |
|
| 15 |
"CographTheme", |
|
| 16 |
public = list( |
|
| 17 |
#' @description Create a new CographTheme object. |
|
| 18 |
#' @param name Theme name (optional). |
|
| 19 |
#' @param background Background color. |
|
| 20 |
#' @param node_fill Default node fill color. |
|
| 21 |
#' @param node_border Default node border color. |
|
| 22 |
#' @param node_border_width Default node border width. |
|
| 23 |
#' @param edge_color Default edge color. |
|
| 24 |
#' @param edge_positive_color Color for positive edge weights. |
|
| 25 |
#' @param edge_negative_color Color for negative edge weights. |
|
| 26 |
#' @param edge_width Default edge width. |
|
| 27 |
#' @param label_color Default label color. |
|
| 28 |
#' @param label_size Default label size. |
|
| 29 |
#' @param title_color Title color. |
|
| 30 |
#' @param title_size Title size. |
|
| 31 |
#' @param legend_background Legend background color. |
|
| 32 |
#' @return A new CographTheme object. |
|
| 33 |
initialize = function( |
|
| 34 |
name = "custom", |
|
| 35 |
background = "white", |
|
| 36 |
node_fill = "#4A90D9", |
|
| 37 |
node_border = "#2C5AA0", |
|
| 38 |
node_border_width = 1, |
|
| 39 |
edge_color = "gray50", |
|
| 40 |
edge_positive_color = "#2E7D32", |
|
| 41 |
edge_negative_color = "#C62828", |
|
| 42 |
edge_width = 1, |
|
| 43 |
label_color = "black", |
|
| 44 |
label_size = 10, |
|
| 45 |
title_color = "black", |
|
| 46 |
title_size = 14, |
|
| 47 |
legend_background = "white" |
|
| 48 |
) {
|
|
| 49 | 77x |
private$.name <- name |
| 50 | 77x |
private$.params <- list( |
| 51 | 77x |
background = background, |
| 52 | 77x |
node_fill = node_fill, |
| 53 | 77x |
node_border = node_border, |
| 54 | 77x |
node_border_width = node_border_width, |
| 55 | 77x |
edge_color = edge_color, |
| 56 | 77x |
edge_positive_color = edge_positive_color, |
| 57 | 77x |
edge_negative_color = edge_negative_color, |
| 58 | 77x |
edge_width = edge_width, |
| 59 | 77x |
label_color = label_color, |
| 60 | 77x |
label_size = label_size, |
| 61 | 77x |
title_color = title_color, |
| 62 | 77x |
title_size = title_size, |
| 63 | 77x |
legend_background = legend_background |
| 64 |
) |
|
| 65 | 77x |
invisible(self) |
| 66 |
}, |
|
| 67 | ||
| 68 |
#' @description Get a theme parameter. |
|
| 69 |
#' @param name Parameter name. |
|
| 70 |
#' @return Parameter value. |
|
| 71 |
get = function(name) {
|
|
| 72 | 634x |
private$.params[[name]] |
| 73 |
}, |
|
| 74 | ||
| 75 |
#' @description Set a theme parameter. |
|
| 76 |
#' @param name Parameter name. |
|
| 77 |
#' @param value Parameter value. |
|
| 78 |
set = function(name, value) {
|
|
| 79 | 10x |
private$.params[[name]] <- value |
| 80 | 10x |
invisible(self) |
| 81 |
}, |
|
| 82 | ||
| 83 |
#' @description Get all theme parameters. |
|
| 84 |
#' @return List of parameters. |
|
| 85 |
get_all = function() {
|
|
| 86 | 2x |
private$.params |
| 87 |
}, |
|
| 88 | ||
| 89 |
#' @description Merge with another theme. |
|
| 90 |
#' @param other Another CographTheme or list of parameters. |
|
| 91 |
#' @return A new merged CographTheme. |
|
| 92 |
merge = function(other) {
|
|
| 93 | 11x |
if (inherits(other, "CographTheme")) {
|
| 94 | 1x |
other_params <- other$get_all() |
| 95 |
} else {
|
|
| 96 | 10x |
other_params <- other |
| 97 |
} |
|
| 98 | ||
| 99 | 11x |
new_params <- utils::modifyList(private$.params, other_params) |
| 100 | ||
| 101 | 11x |
do.call(CographTheme$new, c(list(name = "merged"), new_params)) |
| 102 |
}, |
|
| 103 | ||
| 104 |
#' @description Clone the theme. |
|
| 105 |
#' @return A new CographTheme. |
|
| 106 |
clone_theme = function() {
|
|
| 107 | 2x |
do.call(CographTheme$new, c(list(name = private$.name), private$.params)) |
| 108 |
}, |
|
| 109 | ||
| 110 |
#' @description Print theme summary. |
|
| 111 |
print = function() {
|
|
| 112 | 7x |
cat("CographTheme:", private$.name, "\n")
|
| 113 | 7x |
cat(" Background:", private$.params$background, "\n")
|
| 114 | 7x |
cat(" Node fill:", private$.params$node_fill, "\n")
|
| 115 | 7x |
cat(" Node border:", private$.params$node_border, "\n")
|
| 116 | 7x |
cat(" Edge color:", private$.params$edge_color, "\n")
|
| 117 | 7x |
cat(" Edge positive:", private$.params$edge_positive_color, "\n")
|
| 118 | 7x |
cat(" Edge negative:", private$.params$edge_negative_color, "\n")
|
| 119 | 7x |
invisible(self) |
| 120 |
} |
|
| 121 |
), |
|
| 122 | ||
| 123 |
active = list( |
|
| 124 |
#' @field name Theme name. |
|
| 125 |
name = function() {
|
|
| 126 | 20x |
private$.name |
| 127 |
} |
|
| 128 |
), |
|
| 129 | ||
| 130 |
private = list( |
|
| 131 |
.name = NULL, |
|
| 132 |
.params = NULL |
|
| 133 |
) |
|
| 134 |
) |
|
| 135 | ||
| 136 |
#' @title Check if object is a CographTheme |
|
| 137 |
#' @param x Object to check. |
|
| 138 |
#' @return Logical. |
|
| 139 |
#' @keywords internal |
|
| 140 |
is_cograph_theme <- function(x) {
|
|
| 141 | 4x |
inherits(x, "CographTheme") |
| 142 |
} |
| 1 |
#' @title Scaling Constants |
|
| 2 |
#' @description Central scaling constants for parameter alignment between splot/soplot. |
|
| 3 |
#' @name scale-constants |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' qgraph Scaling Constants (Exact Values) |
|
| 8 |
#' |
|
| 9 |
#' Scaling constants that exactly replicate qgraph's visual formulas. |
|
| 10 |
#' Used by splot() for qgraph-compatible network visualization. |
|
| 11 |
#' |
|
| 12 |
#' @format A list with the following elements: |
|
| 13 |
#' \describe{
|
|
| 14 |
#' \item{vsize_base}{Base multiplier in vsize formula: 8}
|
|
| 15 |
#' \item{vsize_decay}{Decay constant in vsize formula: 80}
|
|
| 16 |
#' \item{vsize_min}{Minimum added to vsize: 1}
|
|
| 17 |
#' \item{vsize_factor}{Scale factor to convert vsize to user coordinates: 0.015}
|
|
| 18 |
#' \item{esize_base}{Base multiplier in esize formula: 15}
|
|
| 19 |
#' \item{esize_decay}{Decay constant in esize formula: 90}
|
|
| 20 |
#' \item{esize_min}{Minimum added to esize: 1}
|
|
| 21 |
#' \item{esize_unweighted}{Default edge width for unweighted networks: 2}
|
|
| 22 |
#' \item{cent2edge_divisor}{Divisor in cent2edge formula: 17.5}
|
|
| 23 |
#' \item{cent2edge_reference}{Reference value in cent2edge: 2.16}
|
|
| 24 |
#' \item{cent2edge_plot_ref}{Plot reference size: 7}
|
|
| 25 |
#' \item{curve_ref_diagonal}{Diagonal reference for curve normalization: sqrt(98)}
|
|
| 26 |
#' \item{arrow_factor}{Arrow size scale factor: 0.04}
|
|
| 27 |
#' } |
|
| 28 |
#' |
|
| 29 |
#' @keywords internal |
|
| 30 |
QGRAPH_SCALE <- list( |
|
| 31 |
# vsize formula: 8 * exp(-n/80) + 1 |
|
| 32 |
vsize_base = 8, |
|
| 33 |
vsize_decay = 80, |
|
| 34 |
vsize_min = 1, |
|
| 35 |
vsize_factor = 0.012, # Calibrated: converts vsize units to user coordinates |
|
| 36 | ||
| 37 |
# esize formula: 15 * exp(-n/90) + 1 |
|
| 38 |
# Note: qgraph's esize ~15 visually corresponds to lwd ~4 |
|
| 39 |
# Use esize_scale to convert qgraph esize to lwd |
|
| 40 |
esize_base = 15, |
|
| 41 |
esize_decay = 90, |
|
| 42 |
esize_min = 1, |
|
| 43 |
esize_unweighted = 2, |
|
| 44 |
esize_scale = 0.27, # Calibrated: qgraph_esize * scale = lwd |
|
| 45 | ||
| 46 |
# Cent2Edge constants (for exact qgraph boundary calculations) |
|
| 47 |
cent2edge_divisor = 17.5, |
|
| 48 |
cent2edge_reference = 2.16, |
|
| 49 |
cent2edge_plot_ref = 7, |
|
| 50 | ||
| 51 |
# Curve normalization: sqrt(pin[1]^2 + pin[2]^2) / sqrt(7^2 + 7^2) |
|
| 52 |
curve_ref_diagonal = sqrt(7^2 + 7^2), |
|
| 53 | ||
| 54 |
# Arrow sizing |
|
| 55 |
# Visible but not overpowering at default arrow_size=1 |
|
| 56 |
arrow_factor = 0.04 |
|
| 57 |
) |
|
| 58 | ||
| 59 |
#' cograph Scaling Constants |
|
| 60 |
#' |
|
| 61 |
#' Central location for all scaling factors used in splot() and soplot(). |
|
| 62 |
#' These constants are calibrated to produce similar visual output to qgraph |
|
| 63 |
#' when using equivalent parameter values. |
|
| 64 |
#' |
|
| 65 |
#' @details |
|
| 66 |
#' The default scaling mode uses values calibrated to match qgraph visual appearance: |
|
| 67 |
#' - `node_size = 6` in cograph should look similar to `vsize = 6` in qgraph |
|
| 68 |
#' - `label_size = 1` uses cex-style multiplier (independent of node size) |
|
| 69 |
#' - `arrow_size = 1` produces consistent arrows between splot and soplot |
|
| 70 |
#' |
|
| 71 |
#' Legacy mode preserves the original cograph v1.x behavior where: |
|
| 72 |
#' - Node sizes used a 0.04 scale factor |
|
| 73 |
#' - Label sizes were coupled to node size (vsize * 8) |
|
| 74 |
#' - Arrow sizes differed between splot (0.03) and soplot (0.015) |
|
| 75 |
#' |
|
| 76 |
#' @format A list with the following elements: |
|
| 77 |
#' \describe{
|
|
| 78 |
#' \item{node_factor}{Scale factor applied to node_size parameter}
|
|
| 79 |
#' \item{node_default}{Default node size when not specified}
|
|
| 80 |
#' \item{label_default}{Default label size (cex multiplier)}
|
|
| 81 |
#' \item{label_coupled}{Whether label size is coupled to node size}
|
|
| 82 |
#' \item{edge_base}{Base edge width}
|
|
| 83 |
#' \item{edge_scale}{Edge width scale factor}
|
|
| 84 |
#' \item{edge_default}{Default edge width}
|
|
| 85 |
#' \item{arrow_factor}{Scale factor for arrow sizes}
|
|
| 86 |
#' \item{arrow_default}{Default arrow size}
|
|
| 87 |
#' } |
|
| 88 |
#' |
|
| 89 |
#' @keywords internal |
|
| 90 |
COGRAPH_SCALE <- list( |
|
| 91 |
# Node sizing: node_size=6 should look like qgraph vsize=6 |
|
| 92 |
# Calibrated: 6 * 0.015 = 0.09 user coords (similar visual size to qgraph) |
|
| 93 |
node_factor = 0.015, |
|
| 94 |
node_default = 6, |
|
| 95 | ||
| 96 |
# Label sizing: independent of node, cex-style |
|
| 97 |
# label_size=1 is the baseline (like cex=1 in base R) |
|
| 98 | ||
| 99 |
label_default = 1, |
|
| 100 |
label_coupled = FALSE, |
|
| 101 | ||
| 102 |
# Edge sizing (legacy simple parameters) |
|
| 103 |
edge_base = 0.5, |
|
| 104 |
edge_scale = 3, |
|
| 105 |
edge_default = 1, |
|
| 106 | ||
| 107 |
# Edge width scaling (qgraph-matched + extensions) |
|
| 108 |
# Output range [min_width, max_width] for scaled edges |
|
| 109 |
edge_width_range = c(0.1, 4), |
|
| 110 |
# Scaling mode: "linear", "log", "sqrt", "rank" |
|
| 111 |
edge_scale_mode = "linear", |
|
| 112 |
# Default cut = 75th percentile when NULL |
|
| 113 |
edge_cut_quantile = 0.75, |
|
| 114 |
# Default width when no weights present |
|
| 115 |
edge_width_default = 1, |
|
| 116 | ||
| 117 |
# Arrow sizing - unified between splot and soplot |
|
| 118 |
# Visible but not overpowering at default arrow_size=1 |
|
| 119 |
arrow_factor = 0.04, |
|
| 120 |
arrow_default = 1, |
|
| 121 | ||
| 122 |
# soplot-specific: NPC coordinates |
|
| 123 |
# When converting node_size for soplot (NPC coords), use this factor |
|
| 124 |
# Calibrated: splot uses ~2.6 user coord range, soplot uses 1.0 NPC |
|
| 125 |
# To match: 0.015 / 2.6 ≈ 0.006 |
|
| 126 |
soplot_node_factor = 0.006 |
|
| 127 |
) |
|
| 128 | ||
| 129 |
#' Legacy Scaling Constants (Pre-v2.0 Behavior) |
|
| 130 |
#' |
|
| 131 |
#' Scaling constants that preserve the original cograph v1.x behavior. |
|
| 132 |
#' Use `scaling = "legacy"` to enable these values. |
|
| 133 |
#' |
|
| 134 |
#' @format A list with the same structure as \code{COGRAPH_SCALE}
|
|
| 135 |
#' @keywords internal |
|
| 136 |
COGRAPH_SCALE_LEGACY <- list( |
|
| 137 |
# Original splot values |
|
| 138 |
node_factor = 0.04, |
|
| 139 |
node_default = 3, |
|
| 140 | ||
| 141 |
# Label size coupled to node size (vsize * 8) |
|
| 142 |
label_default = NULL, |
|
| 143 |
label_coupled = TRUE, |
|
| 144 | ||
| 145 |
# Edge sizing (unchanged) |
|
| 146 |
edge_base = 0.5, |
|
| 147 |
edge_scale = 3, |
|
| 148 |
edge_default = NULL, |
|
| 149 | ||
| 150 |
# Edge width scaling (legacy uses simpler linear scaling) |
|
| 151 |
edge_width_range = c(0.5, 4), |
|
| 152 |
edge_scale_mode = "linear", |
|
| 153 |
edge_cut_quantile = 0.75, |
|
| 154 |
edge_width_default = 1, |
|
| 155 | ||
| 156 |
# Original arrow factors |
|
| 157 |
# splot used 0.03, soplot used 0.015 |
|
| 158 |
arrow_factor = 0.03, |
|
| 159 |
arrow_factor_soplot = 0.015, |
|
| 160 |
arrow_default = 1, |
|
| 161 | ||
| 162 |
# soplot-specific (original behavior, adjusted for coordinate system) |
|
| 163 |
soplot_node_factor = 0.004 |
|
| 164 |
) |
|
| 165 | ||
| 166 |
#' Get Scaling Constants |
|
| 167 |
#' |
|
| 168 |
#' Returns the appropriate scaling constants based on the scaling mode. |
|
| 169 |
#' |
|
| 170 |
#' @param scaling Character: "default" for qgraph-matched scaling, |
|
| 171 |
#' "legacy" for pre-v2.0 behavior. |
|
| 172 |
#' @return A list of scaling constants. |
|
| 173 |
#' @keywords internal |
|
| 174 |
get_scale_constants <- function(scaling = "default") {
|
|
| 175 | 3166x |
if (identical(scaling, "legacy")) {
|
| 176 | 3x |
COGRAPH_SCALE_LEGACY |
| 177 |
} else {
|
|
| 178 | 3163x |
COGRAPH_SCALE |
| 179 |
} |
|
| 180 |
} |
|
| 181 | ||
| 182 |
#' Compute Adaptive Base Edge Size |
|
| 183 |
#' |
|
| 184 |
#' Calculates the maximum edge width that decreases with more nodes. |
|
| 185 |
#' Inspired by qgraph but scaled for line widths (not pixels). |
|
| 186 |
#' |
|
| 187 |
#' @param n_nodes Number of nodes in the network. |
|
| 188 |
#' @param directed Whether the network is directed (directed networks use thinner edges). |
|
| 189 |
#' @return Numeric maximum edge width (suitable for lwd parameter). |
|
| 190 |
#' |
|
| 191 |
#' @details |
|
| 192 |
#' The formula produces reasonable line widths: |
|
| 193 |
#' - 3 nodes: ~5 |
|
| 194 |
#' - 10 nodes: ~4.5 |
|
| 195 |
#' - 50 nodes: ~3 |
|
| 196 |
#' - 100 nodes: ~2 |
|
| 197 |
#' - 200 nodes: ~1.2 |
|
| 198 |
#' |
|
| 199 |
#' For directed networks, the size is reduced by 30% (minimum 1). |
|
| 200 |
#' |
|
| 201 |
#' @keywords internal |
|
| 202 |
compute_adaptive_esize <- function(n_nodes, directed = FALSE) {
|
|
| 203 |
# Scaled formula for reasonable line widths (0.5 to ~6) |
|
| 204 |
# Uses gentler decay than qgraph's pixel-based formula |
|
| 205 | 1x |
esize <- 4 * exp(-n_nodes / 150) + 1.5 |
| 206 | ||
| 207 | 1x |
if (directed) {
|
| 208 | 1x |
esize <- max(esize * 0.7, 1) |
| 209 |
} |
|
| 210 | ||
| 211 | 1x |
esize |
| 212 |
} |
|
| 213 | ||
| 214 |
#' Scale Edge Widths Based on Weights |
|
| 215 |
#' |
|
| 216 |
#' Unified edge width scaling function that supports multiple scaling modes, |
|
| 217 |
#' two-tier cutoff system (like qgraph), and output range specification. |
|
| 218 |
#' |
|
| 219 |
#' @param weights Numeric vector of edge weights. |
|
| 220 |
#' @param esize Base edge size. NULL uses adaptive sizing based on n_nodes. |
|
| 221 |
#' @param n_nodes Number of nodes (for adaptive esize calculation). |
|
| 222 |
#' @param directed Whether network is directed (affects adaptive esize). |
|
| 223 |
#' @param mode Scaling mode: "linear", "log", "sqrt", or "rank". |
|
| 224 |
#' @param maximum Max weight for normalization. NULL for auto-detect. |
|
| 225 |
#' @param minimum Min weight threshold. Edges below this get minimum width. |
|
| 226 |
#' @param cut Two-tier cutoff threshold. NULL = auto (75th percentile), |
|
| 227 |
#' 0 = disabled (continuous scaling), positive number = manual threshold. |
|
| 228 |
#' @param range Output width range as c(min_width, max_width). |
|
| 229 |
#' @return Numeric vector of scaled edge widths. |
|
| 230 |
#' |
|
| 231 |
#' @details |
|
| 232 |
#' ## Scaling Modes |
|
| 233 |
#' |
|
| 234 |
#' - **linear** (default): Direct proportional scaling, matches qgraph behavior. |
|
| 235 |
#' - **log**: Logarithmic scaling for wide weight ranges. Uses log1p for stability. |
|
| 236 |
#' - **sqrt**: Square root scaling for moderate compression. |
|
| 237 |
#' - **rank**: Rank-based scaling for equal visual spacing regardless of weight distribution. |
|
| 238 |
#' |
|
| 239 |
#' ## Two-Tier System (cut parameter) |
|
| 240 |
#' |
|
| 241 |
#' When cut > 0, edges are divided into two tiers: |
|
| 242 |
#' - Below cut: Minimal width variation (20% of range) |
|
| 243 |
#' - Above cut: Full width scaling (80% of range) |
|
| 244 |
#' |
|
| 245 |
#' This matches qgraph's behavior where weak edges are visually de-emphasized. |
|
| 246 |
#' |
|
| 247 |
#' @examples |
|
| 248 |
#' \dontrun{
|
|
| 249 |
#' weights <- c(0.1, 0.3, 0.5, 0.8, 1.0) |
|
| 250 |
#' |
|
| 251 |
#' # Linear scaling (default) |
|
| 252 |
#' scale_edge_widths(weights, mode = "linear") |
|
| 253 |
#' |
|
| 254 |
#' # Log scaling for wide ranges |
|
| 255 |
#' scale_edge_widths(c(0.01, 0.1, 1, 10, 100), mode = "log") |
|
| 256 |
#' |
|
| 257 |
#' # With two-tier cut |
|
| 258 |
#' scale_edge_widths(weights, cut = 0.5) |
|
| 259 |
#' |
|
| 260 |
#' # Rank-based (equal visual spacing) |
|
| 261 |
#' scale_edge_widths(weights, mode = "rank", cut = 0) |
|
| 262 |
#' } |
|
| 263 |
#' |
|
| 264 |
#' @keywords internal |
|
| 265 |
scale_edge_widths <- function(weights, |
|
| 266 |
esize = NULL, |
|
| 267 |
n_nodes = NULL, |
|
| 268 |
directed = FALSE, |
|
| 269 |
mode = "linear", |
|
| 270 |
maximum = NULL, |
|
| 271 |
minimum = 0, |
|
| 272 |
cut = NULL, |
|
| 273 |
range = c(0.5, 4)) {
|
|
| 274 | 1x |
if (length(weights) == 0) return(numeric(0)) |
| 275 | ||
| 276 |
# Validate scale mode |
|
| 277 | ||
| 278 | 662x |
valid_modes <- c("linear", "log", "sqrt", "rank")
|
| 279 | 662x |
if (!mode %in% valid_modes) {
|
| 280 | 1x |
stop("edge_scale_mode must be one of: ", paste(valid_modes, collapse = ", "),
|
| 281 | 1x |
". Got: '", mode, "'", call. = FALSE) |
| 282 |
} |
|
| 283 | ||
| 284 |
# Use absolute values |
|
| 285 | 661x |
abs_weights <- abs(weights) |
| 286 | ||
| 287 | ||
| 288 |
# Determine effective range for edge widths |
|
| 289 | ||
| 290 |
# Priority: if esize is explicitly provided, it overrides range[2] |
|
| 291 |
# Otherwise, use range as-is (respecting user's edge_width_range) |
|
| 292 | 661x |
if (!is.null(esize)) {
|
| 293 |
# esize explicitly provided - use it as max |
|
| 294 | 3x |
effective_range <- c(range[1], esize) |
| 295 |
} else {
|
|
| 296 |
# No esize - use range directly (user's edge_width_range is respected) |
|
| 297 | 658x |
effective_range <- range |
| 298 |
} |
|
| 299 | ||
| 300 |
# Auto-detect maximum |
|
| 301 | 661x |
if (is.null(maximum)) {
|
| 302 | 656x |
maximum <- max(abs_weights, na.rm = TRUE) |
| 303 |
} |
|
| 304 | 1x |
if (maximum == 0 || is.na(maximum)) maximum <- 1 |
| 305 | ||
| 306 |
# Apply scaling mode to normalize weights |
|
| 307 | 661x |
normalized <- switch(mode, |
| 308 | 661x |
"linear" = abs_weights / maximum, |
| 309 | 661x |
"log" = log1p(abs_weights) / log1p(maximum), |
| 310 | 661x |
"sqrt" = sqrt(abs_weights) / sqrt(maximum), |
| 311 | 661x |
"rank" = {
|
| 312 | 5x |
r <- rank(abs_weights, ties.method = "average", na.last = "keep") |
| 313 | 5x |
min_r <- min(r, na.rm = TRUE) |
| 314 | 5x |
max_r <- max(r, na.rm = TRUE) |
| 315 | 5x |
if (max_r > min_r) {
|
| 316 | 4x |
(r - min_r) / (max_r - min_r) |
| 317 |
} else {
|
|
| 318 | 1x |
rep(0.5, length(abs_weights)) |
| 319 |
} |
|
| 320 |
}, |
|
| 321 | 661x |
abs_weights / maximum # fallback to linear |
| 322 |
) |
|
| 323 | ||
| 324 |
# Handle NA values |
|
| 325 | 661x |
normalized[is.na(normalized)] <- 0 |
| 326 | ||
| 327 |
# Clamp to [0, 1] |
|
| 328 | 661x |
normalized <- pmin(pmax(normalized, 0), 1) |
| 329 | ||
| 330 |
# Simple proportional mapping to effective_range |
|
| 331 |
# (cut parameter now only affects transparency, not width) |
|
| 332 | 661x |
widths <- effective_range[1] + normalized * (effective_range[2] - effective_range[1]) |
| 333 | ||
| 334 |
# Apply minimum threshold (set to min width) |
|
| 335 | 661x |
widths[abs_weights < minimum | is.na(abs_weights)] <- effective_range[1] |
| 336 | ||
| 337 | 661x |
widths |
| 338 |
} |
| 1 |
#' @title Edge List Input Parsing |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing edge list data frames. |
|
| 4 |
#' @name input-edgelist |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse Edge List Data Frame |
|
| 8 |
#' |
|
| 9 |
#' Convert an edge list data frame to internal network format. |
|
| 10 |
#' |
|
| 11 |
#' @param df A data frame with columns for source (from) and target (to) nodes. |
|
| 12 |
#' Optional weight column. Column names are auto-detected. |
|
| 13 |
#' @param directed Logical. Is the network directed? Default TRUE. |
|
| 14 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 15 |
#' @noRd |
|
| 16 |
parse_edgelist <- function(df, directed = NULL) {
|
|
| 17 |
# Validate input |
|
| 18 | 32x |
if (!is.data.frame(df)) {
|
| 19 | 1x |
stop("Input must be a data frame", call. = FALSE)
|
| 20 |
} |
|
| 21 | 31x |
if (nrow(df) == 0) {
|
| 22 | 2x |
stop("Edge list cannot be empty", call. = FALSE)
|
| 23 |
} |
|
| 24 | ||
| 25 |
# Auto-detect column names |
|
| 26 | 29x |
col_names <- tolower(names(df)) |
| 27 | ||
| 28 |
# Find source column |
|
| 29 | 29x |
from_col <- which(col_names %in% c("from", "source", "src", "v1", "node1", "i"))[1]
|
| 30 | 1x |
if (is.na(from_col)) from_col <- 1 |
| 31 | ||
| 32 |
# Find target column |
|
| 33 | 29x |
to_col <- which(col_names %in% c("to", "target", "tgt", "v2", "node2", "j"))[1]
|
| 34 | 2x |
if (is.na(to_col)) to_col <- 2 |
| 35 | ||
| 36 |
# Find weight column |
|
| 37 | 29x |
weight_col <- which(col_names %in% c("weight", "w", "value", "strength"))[1]
|
| 38 | 29x |
has_weight <- !is.na(weight_col) |
| 39 | ||
| 40 |
# Extract columns |
|
| 41 | 29x |
from_vals <- df[[from_col]] |
| 42 | 29x |
to_vals <- df[[to_col]] |
| 43 | ||
| 44 | 29x |
if (has_weight) {
|
| 45 | 13x |
weight_vals <- as.numeric(df[[weight_col]]) |
| 46 |
} else {
|
|
| 47 | 16x |
weight_vals <- rep(1, nrow(df)) |
| 48 |
} |
|
| 49 | ||
| 50 |
# Get unique nodes |
|
| 51 | 29x |
all_nodes <- unique(c(as.character(from_vals), as.character(to_vals))) |
| 52 | 29x |
n <- length(all_nodes) |
| 53 | ||
| 54 |
# Create node ID mapping |
|
| 55 | 29x |
node_map <- setNames(seq_len(n), all_nodes) |
| 56 | ||
| 57 |
# Convert to numeric indices |
|
| 58 | 29x |
from_idx <- as.integer(node_map[as.character(from_vals)]) |
| 59 | 29x |
to_idx <- as.integer(node_map[as.character(to_vals)]) |
| 60 | ||
| 61 |
# Auto-detect directed if not specified |
|
| 62 | 29x |
if (is.null(directed)) {
|
| 63 |
# Check for bidirectional edges |
|
| 64 | 27x |
edge_pairs <- paste(pmin(from_idx, to_idx), pmax(from_idx, to_idx), sep = "-") |
| 65 | 27x |
directed <- length(edge_pairs) != length(unique(edge_pairs)) |
| 66 | 27x |
if (!directed) {
|
| 67 |
# Also check if same edge appears twice with different directions |
|
| 68 | 11x |
edge_dir <- paste(from_idx, to_idx, sep = "->") |
| 69 | 11x |
edge_rev <- paste(to_idx, from_idx, sep = "->") |
| 70 | 11x |
directed <- any(edge_dir %in% edge_rev) |
| 71 |
} |
|
| 72 |
} |
|
| 73 | ||
| 74 |
# Create data structures |
|
| 75 | 29x |
nodes <- create_nodes_df(n, all_nodes) |
| 76 | 29x |
edges <- create_edges_df(from_idx, to_idx, weight_vals, directed) |
| 77 | ||
| 78 | 29x |
list( |
| 79 | 29x |
nodes = nodes, |
| 80 | 29x |
edges = edges, |
| 81 | 29x |
directed = directed, |
| 82 | 29x |
weights = weight_vals |
| 83 |
) |
|
| 84 |
} |
| 1 |
#' @title Custom SVG Node Shapes |
|
| 2 |
#' @description Functions for rendering custom SVG shapes as nodes. |
|
| 3 |
#' @name shapes-svg |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
# Global registry for custom SVG shapes |
|
| 8 |
svg_shape_registry <- new.env(parent = emptyenv()) |
|
| 9 | ||
| 10 |
#' Register Custom SVG Shape |
|
| 11 |
#' |
|
| 12 |
#' Register an SVG file or string as a custom node shape. |
|
| 13 |
#' |
|
| 14 |
#' @param name Character: unique name for this shape (used in node_shape parameter). |
|
| 15 |
#' @param svg_source Character: path to SVG file OR inline SVG string. |
|
| 16 |
#' @return Invisible NULL. The shape is registered for use with sn_nodes(). |
|
| 17 |
#' @export |
|
| 18 |
#' |
|
| 19 |
#' @examples |
|
| 20 |
#' \dontrun{
|
|
| 21 |
#' # Register from file |
|
| 22 |
#' register_svg_shape("custom_icon", "path/to/icon.svg")
|
|
| 23 |
#' |
|
| 24 |
#' # Register from inline SVG |
|
| 25 |
#' register_svg_shape("simple_star",
|
|
| 26 |
#' '<svg viewBox="0 0 100 100"> |
|
| 27 |
#' <polygon points="50,5 20,99 95,39 5,39 80,99" fill="currentColor"/> |
|
| 28 |
#' </svg>') |
|
| 29 |
#' |
|
| 30 |
#' # Use in network |
|
| 31 |
#' cograph(adj) |> sn_nodes(shape = "custom_icon") |
|
| 32 |
#' } |
|
| 33 |
register_svg_shape <- function(name, svg_source) {
|
|
| 34 | 35x |
if (!is.character(name) || length(name) != 1) {
|
| 35 | 5x |
stop("name must be a single character string", call. = FALSE)
|
| 36 |
} |
|
| 37 | ||
| 38 | 30x |
if (!is.character(svg_source) || length(svg_source) != 1) {
|
| 39 | 6x |
stop("svg_source must be a single character string (file path or SVG content)",
|
| 40 | 6x |
call. = FALSE) |
| 41 |
} |
|
| 42 | ||
| 43 |
# Check if it's a file path or inline SVG |
|
| 44 | 24x |
is_file <- file.exists(svg_source) |
| 45 | ||
| 46 |
# Store the SVG data |
|
| 47 | 24x |
svg_data <- list( |
| 48 | 24x |
source = svg_source, |
| 49 | 24x |
is_file = is_file, |
| 50 | 24x |
parsed = NULL # Will be populated on first use |
| 51 |
) |
|
| 52 | ||
| 53 |
# Register in the SVG shape registry |
|
| 54 | 24x |
svg_shape_registry[[name]] <- svg_data |
| 55 | ||
| 56 |
# Also register as a shape for the main registry |
|
| 57 | 24x |
register_shape(name, function(x, y, size, fill, border_color, border_width, |
| 58 | 24x |
alpha = 1, svg_preserve_aspect = TRUE, ...) {
|
| 59 | 13x |
draw_svg_shape(x, y, size, svg_data, fill, border_color, border_width, |
| 60 | 13x |
alpha, svg_preserve_aspect) |
| 61 |
}) |
|
| 62 | ||
| 63 | 24x |
invisible(NULL) |
| 64 |
} |
|
| 65 | ||
| 66 |
#' Get Registered SVG Shape |
|
| 67 |
#' |
|
| 68 |
#' Retrieve SVG shape data by name. |
|
| 69 |
#' |
|
| 70 |
#' @param name Shape name. |
|
| 71 |
#' @return SVG data list or NULL if not found. |
|
| 72 |
#' @keywords internal |
|
| 73 |
get_svg_shape <- function(name) {
|
|
| 74 | 205x |
if (exists(name, envir = svg_shape_registry)) {
|
| 75 | 19x |
svg_shape_registry[[name]] |
| 76 |
} else {
|
|
| 77 | 186x |
NULL |
| 78 |
} |
|
| 79 |
} |
|
| 80 | ||
| 81 |
#' Parse SVG Content |
|
| 82 |
#' |
|
| 83 |
#' Parse SVG from string or file. |
|
| 84 |
#' |
|
| 85 |
#' @param svg_data SVG data list from registry. |
|
| 86 |
#' @return Parsed SVG object (grImport2 Picture or NULL). |
|
| 87 |
#' @keywords internal |
|
| 88 |
parse_svg <- function(svg_data) {
|
|
| 89 | 29x |
if (!is.null(svg_data$parsed)) {
|
| 90 | 2x |
return(svg_data$parsed) |
| 91 |
} |
|
| 92 | ||
| 93 |
# Check for grImport2 package |
|
| 94 | 27x |
if (!has_package("grImport2")) {
|
| 95 | 2x |
warning("Package 'grImport2' is required for SVG shapes. ",
|
| 96 | 2x |
"Install with: install.packages('grImport2')",
|
| 97 | 2x |
call. = FALSE) |
| 98 | 2x |
return(NULL) |
| 99 |
} |
|
| 100 | ||
| 101 | 25x |
tryCatch({
|
| 102 | 25x |
if (svg_data$is_file) {
|
| 103 |
# Read from file |
|
| 104 | 1x |
parsed <- grImport2::readPicture(svg_data$source) |
| 105 |
} else {
|
|
| 106 |
# Parse from string - write to temp file first |
|
| 107 | 24x |
temp_file <- tempfile(fileext = ".svg") |
| 108 | 24x |
on.exit(unlink(temp_file), add = TRUE) |
| 109 | 24x |
writeLines(svg_data$source, temp_file) |
| 110 | 24x |
parsed <- grImport2::readPicture(temp_file) |
| 111 |
} |
|
| 112 | ||
| 113 |
# Cache the parsed result |
|
| 114 | 18x |
svg_data$parsed <- parsed |
| 115 | 18x |
parsed |
| 116 | 25x |
}, error = function(e) {
|
| 117 | 6x |
warning("Failed to parse SVG: ", e$message, call. = FALSE)
|
| 118 | 6x |
NULL |
| 119 |
}) |
|
| 120 |
} |
|
| 121 | ||
| 122 |
#' Draw SVG Shape (Grid) |
|
| 123 |
#' |
|
| 124 |
#' Render an SVG as a node shape using grid graphics. |
|
| 125 |
#' |
|
| 126 |
#' @param x,y Node center coordinates (NPC units). |
|
| 127 |
#' @param size Node size (NPC units). |
|
| 128 |
#' @param svg_data SVG data list from registry. |
|
| 129 |
#' @param fill Fill color (replaces SVG fill colors). |
|
| 130 |
#' @param border_color Border color. |
|
| 131 |
#' @param border_width Border width. |
|
| 132 |
#' @param alpha Transparency. |
|
| 133 |
#' @param preserve_aspect Maintain SVG aspect ratio. |
|
| 134 |
#' @return Grid grob or nullGrob if SVG unavailable. |
|
| 135 |
#' @keywords internal |
|
| 136 |
draw_svg_shape <- function(x, y, size, svg_data, fill, border_color, border_width, |
|
| 137 |
alpha = 1, preserve_aspect = TRUE) {
|
|
| 138 | ||
| 139 | 21x |
parsed <- parse_svg(svg_data) |
| 140 | ||
| 141 | 21x |
if (is.null(parsed)) {
|
| 142 |
# Fallback to circle if SVG parsing fails |
|
| 143 | 7x |
fill_col <- adjust_alpha(fill, alpha) |
| 144 | 7x |
border_col <- adjust_alpha(border_color, alpha) |
| 145 | ||
| 146 | 7x |
return(grid::circleGrob( |
| 147 | 7x |
x = grid::unit(x, "npc"), |
| 148 | 7x |
y = grid::unit(y, "npc"), |
| 149 | 7x |
r = grid::unit(size, "npc"), |
| 150 | 7x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 151 |
)) |
|
| 152 |
} |
|
| 153 | ||
| 154 |
# Create viewport for the SVG |
|
| 155 | 14x |
vp <- grid::viewport( |
| 156 | 14x |
x = grid::unit(x, "npc"), |
| 157 | 14x |
y = grid::unit(y, "npc"), |
| 158 | 14x |
width = grid::unit(size * 2, "npc"), |
| 159 | 14x |
height = grid::unit(size * 2, "npc") |
| 160 |
) |
|
| 161 | ||
| 162 |
# Draw the picture in the viewport |
|
| 163 |
# Note: grImport2::pictureGrob handles the rendering |
|
| 164 | 14x |
tryCatch({
|
| 165 | 14x |
grob <- grImport2::pictureGrob( |
| 166 | 14x |
parsed, |
| 167 | 14x |
x = 0.5, y = 0.5, |
| 168 | 14x |
width = 1, height = 1, |
| 169 | 14x |
just = "center", |
| 170 | 14x |
default.units = "npc", |
| 171 | 14x |
expansion = 0, |
| 172 | 14x |
clip = "off" |
| 173 |
) |
|
| 174 | ||
| 175 |
# Wrap in a gTree with the viewport |
|
| 176 | 1x |
grid::gTree( |
| 177 | 1x |
children = grid::gList(grob), |
| 178 | 1x |
vp = vp |
| 179 |
) |
|
| 180 | 14x |
}, error = function(e) {
|
| 181 | 13x |
warning("Failed to render SVG: ", e$message, call. = FALSE)
|
| 182 | ||
| 183 |
# Fallback to circle |
|
| 184 | 13x |
fill_col <- adjust_alpha(fill, alpha) |
| 185 | 13x |
border_col <- adjust_alpha(border_color, alpha) |
| 186 | ||
| 187 | 13x |
grid::circleGrob( |
| 188 | 13x |
x = grid::unit(x, "npc"), |
| 189 | 13x |
y = grid::unit(y, "npc"), |
| 190 | 13x |
r = grid::unit(size, "npc"), |
| 191 | 13x |
gp = grid::gpar(fill = fill_col, col = border_col, lwd = border_width) |
| 192 |
) |
|
| 193 |
}) |
|
| 194 |
} |
|
| 195 | ||
| 196 |
#' Draw SVG Shape (Base R) |
|
| 197 |
#' |
|
| 198 |
#' Render an SVG as a node shape using base R graphics. |
|
| 199 |
#' Falls back to circle if rasterization fails. |
|
| 200 |
#' |
|
| 201 |
#' @param x,y Node center coordinates. |
|
| 202 |
#' @param size Node size. |
|
| 203 |
#' @param svg_data SVG data list from registry. |
|
| 204 |
#' @param fill Fill color. |
|
| 205 |
#' @param border_color Border color. |
|
| 206 |
#' @param border_width Border width. |
|
| 207 |
#' @keywords internal |
|
| 208 |
draw_svg_shape_base <- function(x, y, size, svg_data, fill, border_color, border_width) {
|
|
| 209 |
# For Base R, we attempt to use rsvg to rasterize and rasterImage to draw |
|
| 210 |
# This requires the 'rsvg' package |
|
| 211 | ||
| 212 | 15x |
if (!has_package("rsvg")) {
|
| 213 |
# Fallback to circle |
|
| 214 | 1x |
graphics::symbols( |
| 215 | 1x |
x = x, y = y, |
| 216 | 1x |
circles = size, |
| 217 | 1x |
inches = FALSE, add = TRUE, |
| 218 | 1x |
fg = border_color, bg = fill, lwd = border_width |
| 219 |
) |
|
| 220 | 1x |
return(invisible()) |
| 221 |
} |
|
| 222 | ||
| 223 | 14x |
tryCatch({
|
| 224 |
# Get SVG content |
|
| 225 | 14x |
svg_content <- if (svg_data$is_file) {
|
| 226 | 1x |
readLines(svg_data$source, warn = FALSE) |
| 227 |
} else {
|
|
| 228 | 13x |
svg_data$source |
| 229 |
} |
|
| 230 | 14x |
svg_content <- paste(svg_content, collapse = "\n") |
| 231 | ||
| 232 |
# Rasterize to bitmap |
|
| 233 | 14x |
bitmap <- rsvg::rsvg(charToRaw(svg_content), width = 100, height = 100) |
| 234 | ||
| 235 |
# Draw as raster image |
|
| 236 | 13x |
graphics::rasterImage( |
| 237 | 13x |
bitmap, |
| 238 | 13x |
xleft = x - size, |
| 239 | 13x |
ybottom = y - size, |
| 240 | 13x |
xright = x + size, |
| 241 | 13x |
ytop = y + size |
| 242 |
) |
|
| 243 | 14x |
}, error = function(e) {
|
| 244 |
# Fallback to circle |
|
| 245 | 1x |
graphics::symbols( |
| 246 | 1x |
x = x, y = y, |
| 247 | 1x |
circles = size, |
| 248 | 1x |
inches = FALSE, add = TRUE, |
| 249 | 1x |
fg = border_color, bg = fill, lwd = border_width |
| 250 |
) |
|
| 251 |
}) |
|
| 252 | ||
| 253 | 14x |
invisible() |
| 254 |
} |
|
| 255 | ||
| 256 |
#' List Registered SVG Shapes |
|
| 257 |
#' |
|
| 258 |
#' Get names of all registered custom SVG shapes. |
|
| 259 |
#' |
|
| 260 |
#' @return Character vector of registered shape names. |
|
| 261 |
#' @export |
|
| 262 |
#' |
|
| 263 |
#' @examples |
|
| 264 |
#' list_svg_shapes() |
|
| 265 |
list_svg_shapes <- function() {
|
|
| 266 | 10x |
ls(envir = svg_shape_registry) |
| 267 |
} |
|
| 268 | ||
| 269 |
#' Unregister SVG Shape |
|
| 270 |
#' |
|
| 271 |
#' Remove a custom SVG shape from the registry. |
|
| 272 |
#' |
|
| 273 |
#' @param name Shape name to remove. |
|
| 274 |
#' @return Invisible TRUE if removed, FALSE if not found. |
|
| 275 |
#' @export |
|
| 276 |
#' @examples |
|
| 277 |
#' # Attempt to unregister a non-existent shape (returns FALSE) |
|
| 278 |
#' unregister_svg_shape("nonexistent")
|
|
| 279 |
unregister_svg_shape <- function(name) {
|
|
| 280 | 18x |
if (exists(name, envir = svg_shape_registry)) {
|
| 281 | 16x |
rm(list = name, envir = svg_shape_registry) |
| 282 | 16x |
invisible(TRUE) |
| 283 |
} else {
|
|
| 284 | 2x |
invisible(FALSE) |
| 285 |
} |
|
| 286 |
} |
| 1 |
#' @title Output and Saving |
|
| 2 |
#' @description Functions for saving network visualizations to files. |
|
| 3 |
#' @name output-save |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Save Network Visualization |
|
| 7 |
#' |
|
| 8 |
#' Save a Cograph network visualization to a file. |
|
| 9 |
#' |
|
| 10 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 11 |
#' Matrices and other inputs are auto-converted. |
|
| 12 |
#' @param filename Output filename. Format is detected from extension. |
|
| 13 |
#' @param width Width in inches (default 7). |
|
| 14 |
#' @param height Height in inches (default 7). |
|
| 15 |
#' @param dpi Resolution for raster formats (default 300). |
|
| 16 |
#' @param title Optional plot title. |
|
| 17 |
#' @param ... Additional arguments passed to the graphics device. |
|
| 18 |
#' |
|
| 19 |
#' @return Invisible filename. |
|
| 20 |
#' @export |
|
| 21 |
#' |
|
| 22 |
#' @examples |
|
| 23 |
#' \dontrun{
|
|
| 24 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 25 |
#' # With cograph() |
|
| 26 |
#' net <- cograph(adj) |
|
| 27 |
#' sn_save(net, "network.pdf") |
|
| 28 |
#' |
|
| 29 |
#' # Direct matrix input |
|
| 30 |
#' sn_save(adj, "network.png", dpi = 300) |
|
| 31 |
#' } |
|
| 32 |
sn_save <- function(network, filename, width = 7, height = 7, dpi = 300, |
|
| 33 |
title = NULL, ...) {
|
|
| 34 | ||
| 35 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 36 | 35x |
network <- ensure_cograph_network(network) |
| 37 | ||
| 38 |
# Detect format from extension |
|
| 39 | 35x |
ext <- tolower(tools::file_ext(filename)) |
| 40 | ||
| 41 | 35x |
if (ext == "") {
|
| 42 | 2x |
stop("Filename must have an extension (e.g., .pdf, .png, .svg)",
|
| 43 | 2x |
call. = FALSE) |
| 44 |
} |
|
| 45 | ||
| 46 |
# Open device |
|
| 47 | 33x |
device_opened <- FALSE |
| 48 | 33x |
on.exit({
|
| 49 | 30x |
if (device_opened) grDevices::dev.off() |
| 50 |
}) |
|
| 51 | ||
| 52 | 33x |
switch(ext, |
| 53 |
pdf = {
|
|
| 54 | 14x |
grDevices::pdf(filename, width = width, height = height, ...) |
| 55 | 14x |
device_opened <- TRUE |
| 56 |
}, |
|
| 57 |
png = {
|
|
| 58 | 11x |
grDevices::png(filename, width = width, height = height, |
| 59 | 11x |
units = "in", res = dpi, ...) |
| 60 | 11x |
device_opened <- TRUE |
| 61 |
}, |
|
| 62 |
svg = {
|
|
| 63 | 1x |
grDevices::svg(filename, width = width, height = height, ...) |
| 64 | ! |
device_opened <- TRUE |
| 65 |
}, |
|
| 66 |
jpeg = , |
|
| 67 |
jpg = {
|
|
| 68 | 2x |
grDevices::jpeg(filename, width = width, height = height, |
| 69 | 2x |
units = "in", res = dpi, quality = 95, ...) |
| 70 | 2x |
device_opened <- TRUE |
| 71 |
}, |
|
| 72 |
tiff = {
|
|
| 73 | 1x |
grDevices::tiff(filename, width = width, height = height, |
| 74 | 1x |
units = "in", res = dpi, compression = "lzw", ...) |
| 75 | 1x |
device_opened <- TRUE |
| 76 |
}, |
|
| 77 |
eps = , |
|
| 78 |
ps = {
|
|
| 79 | 2x |
grDevices::postscript(filename, width = width, height = height, |
| 80 | 2x |
paper = "special", horizontal = FALSE, ...) |
| 81 | 2x |
device_opened <- TRUE |
| 82 |
}, |
|
| 83 |
{
|
|
| 84 | 2x |
stop("Unsupported format: ", ext,
|
| 85 | 2x |
". Supported: pdf, png, svg, jpeg, tiff, eps", call. = FALSE) |
| 86 |
} |
|
| 87 |
) |
|
| 88 | ||
| 89 |
# Render |
|
| 90 | 30x |
sn_render(network, title = title) |
| 91 | ||
| 92 | 28x |
message("Saved to: ", filename)
|
| 93 | 28x |
invisible(filename) |
| 94 |
} |
|
| 95 | ||
| 96 |
#' Save as ggplot2 |
|
| 97 |
#' |
|
| 98 |
#' Save network as a ggplot2 object to file using ggsave. |
|
| 99 |
#' |
|
| 100 |
#' @param network A cograph_network object. |
|
| 101 |
#' @param filename Output filename. |
|
| 102 |
#' @param width Width in inches. |
|
| 103 |
#' @param height Height in inches. |
|
| 104 |
#' @param dpi Resolution for raster formats. |
|
| 105 |
#' @param title Optional plot title. |
|
| 106 |
#' @param ... Additional arguments passed to ggsave. |
|
| 107 |
#' |
|
| 108 |
#' @return Invisible filename. |
|
| 109 |
#' @export |
|
| 110 |
#' |
|
| 111 |
#' @examples |
|
| 112 |
#' \dontrun{
|
|
| 113 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 114 |
#' net <- cograph(adj) |
|
| 115 |
#' sn_save_ggplot(net, "network.pdf") |
|
| 116 |
#' } |
|
| 117 |
sn_save_ggplot <- function(network, filename, width = 7, height = 7, |
|
| 118 |
dpi = 300, title = NULL, ...) {
|
|
| 119 | ||
| 120 | 6x |
p <- sn_ggplot(network, title = title) |
| 121 | 6x |
ggplot2::ggsave(filename, plot = p, width = width, height = height, |
| 122 | 6x |
dpi = dpi, ...) |
| 123 | 6x |
message("Saved to: ", filename)
|
| 124 | 6x |
invisible(filename) |
| 125 |
} |
| 1 |
#' @title qgraph-Compatible Geometry Utilities |
|
| 2 |
#' @description Coordinate transformation and geometry functions that exactly replicate |
|
| 3 |
#' qgraph's visual logic. Used by splot() for qgraph-compatible network visualization. |
|
| 4 |
#' @name sonplot-qgraph-geometry |
|
| 5 |
#' @keywords internal |
|
| 6 |
NULL |
|
| 7 | ||
| 8 |
#' Get Plot Dimension Info |
|
| 9 |
#' |
|
| 10 |
#' Retrieves current plot device information needed for qgraph-style calculations. |
|
| 11 |
#' |
|
| 12 |
#' @return List with usr, pin, mai, csi, and dev_name components. |
|
| 13 |
#' @keywords internal |
|
| 14 |
qgraph_plot_info <- function() {
|
|
| 15 | 7x |
list( |
| 16 | 7x |
usr = graphics::par("usr"),
|
| 17 | 7x |
pin = graphics::par("pin"),
|
| 18 | 7x |
mai = graphics::par("mai"),
|
| 19 | 7x |
csi = graphics::par("csi"),
|
| 20 | 7x |
dev_name = names(grDevices::dev.cur()) |
| 21 |
) |
|
| 22 |
} |
|
| 23 | ||
| 24 |
#' qgraph Default Node Size |
|
| 25 |
#' |
|
| 26 |
#' Calculates the default node size using qgraph's exact formula. |
|
| 27 |
#' Formula: 8 * exp(-n/80) + 1 |
|
| 28 |
#' |
|
| 29 |
#' @param n_nodes Number of nodes in the network. |
|
| 30 |
#' @return Default vsize value (before scale factor conversion). |
|
| 31 |
#' @keywords internal |
|
| 32 |
qgraph_default_vsize <- function(n_nodes) {
|
|
| 33 | 4x |
8 * exp(-n_nodes / 80) + 1 |
| 34 |
} |
|
| 35 | ||
| 36 |
#' qgraph Default Edge Size |
|
| 37 |
#' |
|
| 38 |
#' Calculates the default maximum edge width using qgraph's exact formula. |
|
| 39 |
#' Formula: 15 * exp(-n/90) + 1 (halved for directed networks, minimum 1) |
|
| 40 |
#' |
|
| 41 |
#' @param n_nodes Number of nodes in the network. |
|
| 42 |
#' @param weighted Logical: is the network weighted? |
|
| 43 |
#' @param directed Logical: is the network directed? |
|
| 44 |
#' @return Default esize value. |
|
| 45 |
#' @keywords internal |
|
| 46 |
qgraph_default_esize <- function(n_nodes, weighted = TRUE, directed = FALSE) {
|
|
| 47 | 5x |
if (weighted) {
|
| 48 | 4x |
esize <- 15 * exp(-n_nodes / 90) + 1 |
| 49 | 4x |
if (directed) {
|
| 50 | 2x |
esize <- max(esize / 2, 1) |
| 51 |
} |
|
| 52 |
} else {
|
|
| 53 | 1x |
esize <- 2 |
| 54 |
} |
|
| 55 | 5x |
esize |
| 56 |
} |
|
| 57 | ||
| 58 |
#' qgraph Edge Width Scaling (EXACT) |
|
| 59 |
#' |
|
| 60 |
#' Scales edge weights to widths using qgraph's exact formula. |
|
| 61 |
#' Output range is 1 to esize for continuous scaling (cut = 0). |
|
| 62 |
#' |
|
| 63 |
#' @param weights Numeric vector of edge weights. |
|
| 64 |
#' @param minimum Minimum weight threshold. |
|
| 65 |
#' @param maximum Maximum weight for normalization. |
|
| 66 |
#' @param cut Two-tier cutoff threshold. 0 = continuous scaling. |
|
| 67 |
#' @param esize Maximum edge width. |
|
| 68 |
#' @return Numeric vector of scaled edge widths. |
|
| 69 |
#' @keywords internal |
|
| 70 |
qgraph_scale_edge_widths <- function(weights, minimum = 0, maximum = NULL, |
|
| 71 |
cut = 0, esize = NULL) {
|
|
| 72 | 1x |
if (length(weights) == 0) return(numeric(0)) |
| 73 | ||
| 74 | 5x |
abs_w <- abs(weights) |
| 75 | ||
| 76 |
# Auto-detect maximum |
|
| 77 | 5x |
if (is.null(maximum)) {
|
| 78 | 4x |
maximum <- max(abs_w, na.rm = TRUE) |
| 79 |
} |
|
| 80 | 1x |
if (maximum == 0 || is.na(maximum)) maximum <- 1 |
| 81 | ||
| 82 |
# Auto-detect esize if not provided (assume 5 nodes as fallback) |
|
| 83 | ||
| 84 | 5x |
if (is.null(esize)) {
|
| 85 | 4x |
esize <- 4 # Reasonable default |
| 86 |
} |
|
| 87 | ||
| 88 |
# qgraph-style normalization |
|
| 89 | 5x |
if (cut == 0) {
|
| 90 |
# Continuous scaling: normalize from minimum to maximum |
|
| 91 | 4x |
avgW <- (abs_w - minimum) / (maximum - minimum) |
| 92 |
} else {
|
|
| 93 |
# Two-tier: normalize from cut to maximum |
|
| 94 | 1x |
avgW <- (abs_w - cut) / (maximum - cut) |
| 95 | 1x |
avgW[abs_w < cut] <- 0 |
| 96 |
} |
|
| 97 | ||
| 98 |
# Clamp to [0, 1] |
|
| 99 | 5x |
avgW <- pmax(0, pmin(1, avgW)) |
| 100 | ||
| 101 |
# Map to [min_lwd, esize] range |
|
| 102 |
# Use very small minimum for thin edges on low weights |
|
| 103 | 5x |
min_lwd <- 0.1 |
| 104 | 5x |
avgW * (esize - min_lwd) + min_lwd |
| 105 |
} |
|
| 106 | ||
| 107 |
#' qgraph Cent2Edge (EXACT - critical formula) |
|
| 108 |
#' |
|
| 109 |
#' Calculates the point on node boundary where an edge should connect. |
|
| 110 |
#' This is qgraph's exact formula for positioning arrows and edge endpoints. |
|
| 111 |
#' |
|
| 112 |
#' @param x Node center x coordinate. |
|
| 113 |
#' @param y Node center y coordinate. |
|
| 114 |
#' @param cex Node size (vsize value, not yet scaled). |
|
| 115 |
#' @param offset Additional offset distance. |
|
| 116 |
#' @param angle Angle from node center to target point (radians). |
|
| 117 |
#' @param plot_info Plot dimension info from qgraph_plot_info(). NULL to auto-compute. |
|
| 118 |
#' @return List with x, y coordinates on node boundary. |
|
| 119 |
#' @keywords internal |
|
| 120 |
qgraph_cent2edge <- function(x, y, cex, offset = 0, angle, plot_info = NULL) {
|
|
| 121 | 3x |
if (is.null(plot_info)) {
|
| 122 | 3x |
plot_info <- qgraph_plot_info() |
| 123 |
} |
|
| 124 | ||
| 125 | 3x |
xin <- plot_info$pin[1] |
| 126 | 3x |
yin <- plot_info$pin[2] |
| 127 | 3x |
xmarrange <- plot_info$mai[2] + plot_info$mai[4] |
| 128 | 3x |
ymarrange <- plot_info$mai[1] + plot_info$mai[3] |
| 129 | 3x |
xrange <- plot_info$usr[2] - plot_info$usr[1] |
| 130 | 3x |
yrange <- plot_info$usr[4] - plot_info$usr[3] |
| 131 | 3x |
csi <- plot_info$csi |
| 132 | ||
| 133 |
# SVG device correction factor |
|
| 134 | 3x |
svg_factor <- 1 + 0.5 * (plot_info$dev_name == "devSVG") |
| 135 | ||
| 136 |
# qgraph's exact cent2edge formula |
|
| 137 | 3x |
x_factor <- ((xin + xmarrange) / xin) * (7 / (xin + xmarrange)) * |
| 138 | 3x |
(xrange / 2.16) * svg_factor * csi / 17.5 |
| 139 | 3x |
y_factor <- ((yin + ymarrange) / yin) * (7 / (yin + ymarrange)) * |
| 140 | 3x |
(yrange / 2.16) * svg_factor * csi / 17.5 |
| 141 | ||
| 142 | 3x |
list( |
| 143 | 3x |
x = x + (cex + offset) * x_factor * sin(angle), |
| 144 | 3x |
y = y + (cex + offset) * y_factor * cos(angle) |
| 145 |
) |
|
| 146 |
} |
|
| 147 | ||
| 148 |
#' qgraph Curve Normalization Factor |
|
| 149 |
#' |
|
| 150 |
#' Calculates the normalization factor for edge curvature to maintain |
|
| 151 |
#' consistent visual appearance across different plot sizes. |
|
| 152 |
#' Formula: sqrt(sum(pin^2)) / sqrt(7^2 + 7^2) |
|
| 153 |
#' |
|
| 154 |
#' @return Numeric normalization factor. |
|
| 155 |
#' @keywords internal |
|
| 156 |
qgraph_norm_curve <- function() {
|
|
| 157 | 1x |
pin <- graphics::par("pin")
|
| 158 | 1x |
sqrt(sum(pin^2)) / sqrt(7^2 + 7^2) |
| 159 |
} |
|
| 160 | ||
| 161 |
#' qgraph Node Size to User Coordinates |
|
| 162 |
#' |
|
| 163 |
#' Converts qgraph vsize to user coordinate radius using qgraph's exact logic. |
|
| 164 |
#' |
|
| 165 |
#' @param vsize Node size value (as used in qgraph). |
|
| 166 |
#' @param plot_info Plot dimension info. NULL to auto-compute. |
|
| 167 |
#' @return Node radius in user coordinates. |
|
| 168 |
#' @keywords internal |
|
| 169 |
qgraph_vsize_to_user <- function(vsize, plot_info = NULL) {
|
|
| 170 | 3x |
if (is.null(plot_info)) {
|
| 171 | 3x |
plot_info <- qgraph_plot_info() |
| 172 |
} |
|
| 173 | ||
| 174 | 3x |
xin <- plot_info$pin[1] |
| 175 | 3x |
yin <- plot_info$pin[2] |
| 176 | 3x |
xmarrange <- plot_info$mai[2] + plot_info$mai[4] |
| 177 | 3x |
ymarrange <- plot_info$mai[1] + plot_info$mai[3] |
| 178 | 3x |
xrange <- plot_info$usr[2] - plot_info$usr[1] |
| 179 | 3x |
yrange <- plot_info$usr[4] - plot_info$usr[3] |
| 180 | 3x |
csi <- plot_info$csi |
| 181 | ||
| 182 |
# SVG device correction factor |
|
| 183 | 3x |
svg_factor <- 1 + 0.5 * (plot_info$dev_name == "devSVG") |
| 184 | ||
| 185 |
# Average factor for circular nodes (average of x and y factors) |
|
| 186 | 3x |
x_factor <- ((xin + xmarrange) / xin) * (7 / (xin + xmarrange)) * |
| 187 | 3x |
(xrange / 2.16) * svg_factor * csi / 17.5 |
| 188 | 3x |
y_factor <- ((yin + ymarrange) / yin) * (7 / (yin + ymarrange)) * |
| 189 | 3x |
(yrange / 2.16) * svg_factor * csi / 17.5 |
| 190 | ||
| 191 |
# Use average for approximately circular appearance |
|
| 192 | 3x |
avg_factor <- (x_factor + y_factor) / 2 |
| 193 | ||
| 194 | 3x |
vsize * avg_factor |
| 195 |
} |
|
| 196 | ||
| 197 |
#' qgraph Point on Node Boundary |
|
| 198 |
#' |
|
| 199 |
#' Simplified boundary calculation for splot that approximates qgraph behavior |
|
| 200 |
#' while working with cograph's coordinate system. |
|
| 201 |
#' |
|
| 202 |
#' @param x Node center x coordinate. |
|
| 203 |
#' @param y Node center y coordinate. |
|
| 204 |
#' @param angle Angle to target (radians). |
|
| 205 |
#' @param node_size Node radius in user coordinates. |
|
| 206 |
#' @param shape Node shape. |
|
| 207 |
#' @return List with x, y coordinates on boundary. |
|
| 208 |
#' @keywords internal |
|
| 209 |
qgraph_cent_to_edge_simple <- function(x, y, angle, node_size, shape = "circle") {
|
|
| 210 | 9x |
if (shape == "circle") {
|
| 211 | 1x |
list( |
| 212 | 1x |
x = x + node_size * cos(angle), |
| 213 | 1x |
y = y + node_size * sin(angle) |
| 214 |
) |
|
| 215 | 8x |
} else if (shape == "square" || shape == "rectangle") {
|
| 216 |
# Square/rectangle: find intersection with edges |
|
| 217 | 7x |
a <- angle %% (2 * pi) |
| 218 | 7x |
hw <- node_size |
| 219 | ||
| 220 | 7x |
tan_a <- tan(a) |
| 221 | ||
| 222 | 7x |
if (abs(cos(a)) < 1e-10) {
|
| 223 | 2x |
if (sin(a) > 0) {
|
| 224 | 1x |
list(x = x, y = y + hw) |
| 225 |
} else {
|
|
| 226 | 1x |
list(x = x, y = y - hw) |
| 227 |
} |
|
| 228 | 5x |
} else if (abs(sin(a)) < 1e-10) {
|
| 229 | 2x |
if (cos(a) > 0) {
|
| 230 | 1x |
list(x = x + hw, y = y) |
| 231 |
} else {
|
|
| 232 | 1x |
list(x = x - hw, y = y) |
| 233 |
} |
|
| 234 |
} else {
|
|
| 235 | 3x |
edge_x <- if (cos(a) > 0) hw else -hw |
| 236 | 3x |
edge_y <- edge_x * tan_a |
| 237 | ||
| 238 | 3x |
if (abs(edge_y) <= hw) {
|
| 239 | 2x |
list(x = x + edge_x, y = y + edge_y) |
| 240 |
} else {
|
|
| 241 | 1x |
edge_y <- if (sin(a) > 0) hw else -hw |
| 242 | 1x |
edge_x <- edge_y / tan_a |
| 243 | 1x |
list(x = x + edge_x, y = y + edge_y) |
| 244 |
} |
|
| 245 |
} |
|
| 246 |
} else {
|
|
| 247 |
# Default to circle for other shapes |
|
| 248 | 1x |
list( |
| 249 | 1x |
x = x + node_size * cos(angle), |
| 250 | 1x |
y = y + node_size * sin(angle) |
| 251 |
) |
|
| 252 |
} |
|
| 253 |
} |
|
| 254 | ||
| 255 |
#' qgraph-style Arrow Size Calculation |
|
| 256 |
#' |
|
| 257 |
#' Calculates arrow size based on edge width, matching qgraph behavior. |
|
| 258 |
#' |
|
| 259 |
#' @param edge_width Edge line width. |
|
| 260 |
#' @param base_asize Base arrow size multiplier. |
|
| 261 |
#' @return Arrow size in user coordinates. |
|
| 262 |
#' @keywords internal |
|
| 263 |
qgraph_arrow_size <- function(edge_width, base_asize = 1) {
|
|
| 264 |
# qgraph scales arrow size with edge width |
|
| 265 |
# Base size around 0.02 user coords, scaled by edge width |
|
| 266 | 5x |
base_asize * 0.02 * sqrt(edge_width / 2) |
| 267 |
} |
| 1 |
#' @title tna Input Parsing |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing tna objects. |
|
| 4 |
#' @name input-tna |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse tna Object |
|
| 8 |
#' |
|
| 9 |
#' Convert a tna object to internal network format. |
|
| 10 |
#' tna objects are simple lists with $weights (matrix), $labels, and $inits. |
|
| 11 |
#' |
|
| 12 |
#' @param tna_obj A tna object (list with weights matrix). |
|
| 13 |
#' @param directed Logical. Force directed interpretation. NULL uses TRUE (tna networks are directed). |
|
| 14 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 15 |
#' @noRd |
|
| 16 |
parse_tna <- function(tna_obj, directed = NULL) {
|
|
| 17 |
# Validate input |
|
| 18 | 10x |
if (!inherits(tna_obj, "tna")) {
|
| 19 | 1x |
stop("Input must be a tna object", call. = FALSE)
|
| 20 |
} |
|
| 21 | ||
| 22 |
# tna networks are always directed (transition matrices) |
|
| 23 | 9x |
if (is.null(directed)) {
|
| 24 | 8x |
directed <- TRUE |
| 25 |
} |
|
| 26 | ||
| 27 |
# Get the weights matrix |
|
| 28 | 9x |
x <- tna_obj$weights |
| 29 | ||
| 30 |
# Get number of nodes and labels |
|
| 31 | 9x |
n <- nrow(x) |
| 32 | 9x |
labels <- tna_obj$labels |
| 33 | 9x |
if (is.null(labels) || all(is.na(labels))) {
|
| 34 | 1x |
labels <- as.character(seq_len(n)) |
| 35 |
} |
|
| 36 | ||
| 37 |
# Extract edges from matrix |
|
| 38 | 9x |
edge_idx <- which(x != 0, arr.ind = TRUE) |
| 39 | 9x |
if (nrow(edge_idx) == 0) {
|
| 40 | 1x |
from_idx <- integer(0) |
| 41 | 1x |
to_idx <- integer(0) |
| 42 | 1x |
weight_vals <- numeric(0) |
| 43 |
} else {
|
|
| 44 | 8x |
from_idx <- edge_idx[, 1] |
| 45 | 8x |
to_idx <- edge_idx[, 2] |
| 46 | 8x |
weight_vals <- x[edge_idx] |
| 47 |
} |
|
| 48 | ||
| 49 |
# Create data structures |
|
| 50 | 9x |
nodes <- create_nodes_df(n, labels) |
| 51 | 9x |
edges <- create_edges_df(from_idx, to_idx, weight_vals, directed) |
| 52 | ||
| 53 |
# Store initial probabilities as node attribute (for donut visualization) |
|
| 54 | 9x |
if (!is.null(tna_obj$inits)) {
|
| 55 | 4x |
nodes$inits <- as.numeric(tna_obj$inits) |
| 56 |
} |
|
| 57 | ||
| 58 | 9x |
list( |
| 59 | 9x |
nodes = nodes, |
| 60 | 9x |
edges = edges, |
| 61 | 9x |
directed = directed, |
| 62 | 9x |
weights = weight_vals |
| 63 |
) |
|
| 64 |
} |
| 1 |
#' @title Layout Registry Functions |
|
| 2 |
#' @description Functions for registering built-in layouts. |
|
| 3 |
#' @name layout-registry |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Grid Layout |
|
| 8 |
#' |
|
| 9 |
#' Arrange nodes in a grid pattern. |
|
| 10 |
#' |
|
| 11 |
#' @param network A CographNetwork object. |
|
| 12 |
#' @param ncol Number of columns. If NULL, computed as ceiling(sqrt(n)). |
|
| 13 |
#' @param ... Additional arguments (ignored). |
|
| 14 |
#' @return Data frame with x, y coordinates. |
|
| 15 |
#' @keywords internal |
|
| 16 |
layout_grid_fn <- function(network, ncol = NULL, ...) {
|
|
| 17 | 21x |
n <- network$n_nodes |
| 18 | 3x |
if (n == 0) return(data.frame(x = numeric(0), y = numeric(0))) |
| 19 | 4x |
if (n == 1) return(data.frame(x = 0.5, y = 0.5)) |
| 20 | ||
| 21 | 14x |
if (is.null(ncol)) {
|
| 22 | 13x |
ncol <- ceiling(sqrt(n)) |
| 23 |
} |
|
| 24 | 14x |
nrow <- ceiling(n / ncol) |
| 25 | ||
| 26 | 14x |
x <- rep(seq(0.1, 0.9, length.out = ncol), times = nrow)[seq_len(n)] |
| 27 | 14x |
y <- rep(seq(0.9, 0.1, length.out = nrow), each = ncol)[seq_len(n)] |
| 28 | ||
| 29 | 14x |
data.frame(x = x, y = y) |
| 30 |
} |
|
| 31 | ||
| 32 |
#' Random Layout |
|
| 33 |
#' |
|
| 34 |
#' Place nodes at random positions. |
|
| 35 |
#' |
|
| 36 |
#' @param network A CographNetwork object. |
|
| 37 |
#' @param seed Random seed. If NULL, no seed is set. |
|
| 38 |
#' @param ... Additional arguments (ignored). |
|
| 39 |
#' @return Data frame with x, y coordinates. |
|
| 40 |
#' @keywords internal |
|
| 41 |
layout_random_fn <- function(network, seed = NULL, ...) {
|
|
| 42 | 15x |
n <- network$n_nodes |
| 43 | 4x |
if (!is.null(seed)) set.seed(seed) |
| 44 | 15x |
data.frame(x = stats::runif(n, 0.1, 0.9), y = stats::runif(n, 0.1, 0.9)) |
| 45 |
} |
|
| 46 | ||
| 47 |
#' Star Layout |
|
| 48 |
#' |
|
| 49 |
#' Place one node at center, rest in a circle. |
|
| 50 |
#' |
|
| 51 |
#' @param network A CographNetwork object. |
|
| 52 |
#' @param center Index of the center node. Default 1. |
|
| 53 |
#' @param ... Additional arguments (ignored). |
|
| 54 |
#' @return Data frame with x, y coordinates. |
|
| 55 |
#' @keywords internal |
|
| 56 |
layout_star_fn <- function(network, center = 1, ...) {
|
|
| 57 | 19x |
n <- network$n_nodes |
| 58 | 3x |
if (n == 0) return(data.frame(x = numeric(0), y = numeric(0))) |
| 59 | 4x |
if (n == 1) return(data.frame(x = 0.5, y = 0.5)) |
| 60 | ||
| 61 | 12x |
coords <- data.frame(x = numeric(n), y = numeric(n)) |
| 62 | 12x |
coords$x[center] <- 0.5 |
| 63 | 12x |
coords$y[center] <- 0.5 |
| 64 | ||
| 65 | 12x |
others <- setdiff(seq_len(n), center) |
| 66 | 12x |
n_others <- length(others) |
| 67 | ||
| 68 | 12x |
if (n_others > 0) {
|
| 69 | 12x |
angles <- seq(pi/2, pi/2 + 2 * pi * (1 - 1/n_others), |
| 70 | 12x |
length.out = n_others) |
| 71 | 12x |
coords$x[others] <- 0.5 + 0.4 * cos(angles) |
| 72 | 12x |
coords$y[others] <- 0.5 + 0.4 * sin(angles) |
| 73 |
} |
|
| 74 | ||
| 75 | 12x |
coords |
| 76 |
} |
|
| 77 | ||
| 78 |
#' Bipartite Layout |
|
| 79 |
#' |
|
| 80 |
#' Arrange nodes in two columns by type. |
|
| 81 |
#' |
|
| 82 |
#' @param network A CographNetwork object. |
|
| 83 |
#' @param types Vector of type assignments. If NULL, alternates between two types. |
|
| 84 |
#' @param ... Additional arguments (ignored). |
|
| 85 |
#' @return Data frame with x, y coordinates. |
|
| 86 |
#' @keywords internal |
|
| 87 |
layout_bipartite_fn <- function(network, types = NULL, ...) {
|
|
| 88 | 9x |
n <- network$n_nodes |
| 89 | 3x |
if (n == 0) return(data.frame(x = numeric(0), y = numeric(0))) |
| 90 | ||
| 91 | 6x |
if (is.null(types)) {
|
| 92 |
# Default: alternate between two types |
|
| 93 | 5x |
types <- rep(c(0, 1), length.out = n) |
| 94 |
} |
|
| 95 | ||
| 96 | 6x |
type1 <- which(types == unique(types)[1]) |
| 97 | 6x |
type2 <- which(types != unique(types)[1]) |
| 98 | ||
| 99 | 6x |
coords <- data.frame(x = numeric(n), y = numeric(n)) |
| 100 | ||
| 101 |
# Left side |
|
| 102 | 6x |
if (length(type1) > 0) {
|
| 103 | 6x |
coords$x[type1] <- 0.2 |
| 104 | 6x |
coords$y[type1] <- seq(0.9, 0.1, length.out = length(type1)) |
| 105 |
} |
|
| 106 | ||
| 107 |
# Right side |
|
| 108 | 6x |
if (length(type2) > 0) {
|
| 109 | 6x |
coords$x[type2] <- 0.8 |
| 110 | 6x |
coords$y[type2] <- seq(0.9, 0.1, length.out = length(type2)) |
| 111 |
} |
|
| 112 | ||
| 113 | 6x |
coords |
| 114 |
} |
|
| 115 | ||
| 116 |
#' Custom Layout (passthrough) |
|
| 117 |
#' |
|
| 118 |
#' Pass user-provided coordinates through to the layout. |
|
| 119 |
#' |
|
| 120 |
#' @param network A CographNetwork object. |
|
| 121 |
#' @param coords Data frame or matrix with x, y columns. |
|
| 122 |
#' @param ... Additional arguments (ignored). |
|
| 123 |
#' @return Data frame with x, y coordinates. |
|
| 124 |
#' @keywords internal |
|
| 125 |
layout_custom_fn <- function(network, coords, ...) {
|
|
| 126 | 3x |
if (is.matrix(coords)) {
|
| 127 | 2x |
coords <- as.data.frame(coords) |
| 128 |
} |
|
| 129 | 3x |
names(coords)[1:2] <- c("x", "y")
|
| 130 | 3x |
coords |
| 131 |
} |
|
| 132 | ||
| 133 |
#' Register Built-in Layouts |
|
| 134 |
#' |
|
| 135 |
#' Register all built-in layout algorithms. |
|
| 136 |
#' |
|
| 137 |
#' @keywords internal |
|
| 138 |
register_builtin_layouts <- function() {
|
|
| 139 |
# Circle layout |
|
| 140 | 2x |
register_layout("circle", layout_circle)
|
| 141 | ||
| 142 |
# Oval/Ellipse layout |
|
| 143 | 2x |
register_layout("oval", layout_oval)
|
| 144 | 2x |
register_layout("ellipse", layout_oval) # Alias
|
| 145 | ||
| 146 |
# Spring layout (Fruchterman-Reingold) |
|
| 147 | 2x |
register_layout("spring", layout_spring)
|
| 148 | 2x |
register_layout("fr", layout_spring) # Alias
|
| 149 | 2x |
register_layout("fruchterman-reingold", layout_spring) # Alias
|
| 150 | ||
| 151 |
# Groups layout |
|
| 152 | 2x |
register_layout("groups", layout_groups)
|
| 153 | ||
| 154 |
# Grid layout |
|
| 155 | 2x |
register_layout("grid", layout_grid_fn)
|
| 156 | ||
| 157 |
# Random layout |
|
| 158 | 2x |
register_layout("random", layout_random_fn)
|
| 159 | ||
| 160 |
# Star layout (one center node, rest in circle) |
|
| 161 | 2x |
register_layout("star", layout_star_fn)
|
| 162 | ||
| 163 |
# Bipartite layout |
|
| 164 | 2x |
register_layout("bipartite", layout_bipartite_fn)
|
| 165 | ||
| 166 |
# Custom layout (passthrough) |
|
| 167 | 2x |
register_layout("custom", layout_custom_fn)
|
| 168 | ||
| 169 |
# Gephi Fruchterman-Reingold layout |
|
| 170 | 2x |
register_layout("gephi_fr", compute_layout_gephi_fr)
|
| 171 | 2x |
register_layout("gephi", compute_layout_gephi_fr)
|
| 172 |
} |
| 1 |
#' @title ggplot2 Conversion |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Convert Cograph network to ggplot2 object. |
|
| 4 |
#' @name render-ggplot |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Convert Network to ggplot2 |
|
| 8 |
#' |
|
| 9 |
#' Convert a Cograph network visualization to a ggplot2 object for further |
|
| 10 |
#' customization and composability. |
|
| 11 |
#' |
|
| 12 |
#' @param network A cograph_network object, matrix, data.frame, or igraph object. |
|
| 13 |
#' Matrices and other inputs are auto-converted. |
|
| 14 |
#' @param title Optional plot title. |
|
| 15 |
#' |
|
| 16 |
#' @return A ggplot2 object. |
|
| 17 |
#' @export |
|
| 18 |
#' |
|
| 19 |
#' @examples |
|
| 20 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 21 |
#' # With cograph() |
|
| 22 |
#' p <- cograph(adj) |> sn_ggplot() |
|
| 23 |
#' print(p) |
|
| 24 |
#' |
|
| 25 |
#' # Direct matrix input |
|
| 26 |
#' p <- adj |> sn_ggplot() |
|
| 27 |
#' |
|
| 28 |
#' # Further customization |
|
| 29 |
#' p + ggplot2::labs(title = "My Network") |
|
| 30 |
sn_ggplot <- function(network, title = NULL) {
|
|
| 31 |
# Auto-convert matrix/data.frame/igraph to cograph_network |
|
| 32 | 26x |
network <- ensure_cograph_network(network) |
| 33 | ||
| 34 | 26x |
net <- network$network |
| 35 | 26x |
nodes <- net$get_nodes() |
| 36 | 26x |
edges <- net$get_edges() |
| 37 | 26x |
node_aes <- net$get_node_aes() |
| 38 | 26x |
edge_aes <- net$get_edge_aes() |
| 39 | 26x |
theme <- net$get_theme() |
| 40 | ||
| 41 | 26x |
n <- nrow(nodes) |
| 42 | 26x |
m <- if (is.null(edges)) 0 else nrow(edges) |
| 43 | ||
| 44 |
# Theme defaults |
|
| 45 | 26x |
bg_color <- if (!is.null(theme)) theme$get("background") else "white"
|
| 46 | ||
| 47 |
# Resolve node aesthetics |
|
| 48 | 26x |
node_sizes <- recycle_to_length( |
| 49 | 26x |
if (!is.null(node_aes$size)) node_aes$size else 0.05, |
| 50 | 26x |
n |
| 51 |
) |
|
| 52 | 26x |
node_fills <- recycle_to_length( |
| 53 | 26x |
if (!is.null(node_aes$fill)) node_aes$fill else |
| 54 | 26x |
if (!is.null(theme)) theme$get("node_fill") else "#4A90D9",
|
| 55 | 26x |
n |
| 56 |
) |
|
| 57 | 26x |
node_borders <- recycle_to_length( |
| 58 | 26x |
if (!is.null(node_aes$border_color)) node_aes$border_color else |
| 59 | 26x |
if (!is.null(theme)) theme$get("node_border") else "#2C5AA0",
|
| 60 | 26x |
n |
| 61 |
) |
|
| 62 | 26x |
node_border_widths <- recycle_to_length( |
| 63 | 26x |
if (!is.null(node_aes$border_width)) node_aes$border_width else |
| 64 | 26x |
if (!is.null(theme)) theme$get("node_border_width") else 1,
|
| 65 | 26x |
n |
| 66 |
) |
|
| 67 | 26x |
node_alphas <- recycle_to_length( |
| 68 | 26x |
if (!is.null(node_aes$alpha)) node_aes$alpha else 1, |
| 69 | 26x |
n |
| 70 |
) |
|
| 71 | 26x |
node_shapes <- recycle_to_length( |
| 72 | 26x |
if (!is.null(node_aes$shape)) node_aes$shape else "circle", |
| 73 | 26x |
n |
| 74 |
) |
|
| 75 | ||
| 76 |
# Map shapes to ggplot2 shapes |
|
| 77 | 26x |
shape_map <- c( |
| 78 | 26x |
circle = 21, square = 22, triangle = 24, diamond = 23, |
| 79 | 26x |
pentagon = 21, hexagon = 21, ellipse = 21, star = 8, |
| 80 | 26x |
cross = 3, plus = 3 |
| 81 |
) |
|
| 82 | 26x |
gg_shapes <- sapply(node_shapes, function(s) {
|
| 83 | 3x |
if (s %in% names(shape_map)) shape_map[[s]] else 21 |
| 84 |
}) |
|
| 85 | ||
| 86 |
# Build node data frame |
|
| 87 | 26x |
node_df <- data.frame( |
| 88 | 26x |
x = nodes$x, |
| 89 | 26x |
y = nodes$y, |
| 90 | 26x |
label = if (!is.null(nodes$label)) nodes$label else seq_len(n), |
| 91 | 26x |
size = node_sizes * 100, # Scale for ggplot |
| 92 | 26x |
fill = node_fills, |
| 93 | 26x |
border = node_borders, |
| 94 | 26x |
border_width = node_border_widths, |
| 95 | 26x |
alpha = node_alphas, |
| 96 | 26x |
shape = gg_shapes, |
| 97 | 26x |
stringsAsFactors = FALSE |
| 98 |
) |
|
| 99 | ||
| 100 |
# Build edge data frame |
|
| 101 | 26x |
if (m > 0) {
|
| 102 |
# Resolve edge aesthetics |
|
| 103 | 24x |
edge_widths <- recycle_to_length( |
| 104 | 24x |
if (!is.null(edge_aes$width)) edge_aes$width else |
| 105 | 24x |
if (!is.null(theme)) theme$get("edge_width") else 1,
|
| 106 | 24x |
m |
| 107 |
) |
|
| 108 | ||
| 109 | 24x |
if (!is.null(edge_aes$color)) {
|
| 110 | 20x |
edge_colors <- recycle_to_length(edge_aes$color, m) |
| 111 |
} else {
|
|
| 112 | 4x |
pos_col <- if (!is.null(edge_aes$positive_color)) edge_aes$positive_color else |
| 113 | 4x |
if (!is.null(theme)) theme$get("edge_positive_color") else "#2E7D32"
|
| 114 | 4x |
neg_col <- if (!is.null(edge_aes$negative_color)) edge_aes$negative_color else |
| 115 | 4x |
if (!is.null(theme)) theme$get("edge_negative_color") else "#C62828"
|
| 116 | 4x |
default_col <- if (!is.null(theme)) theme$get("edge_color") else "gray50"
|
| 117 | 4x |
edge_colors <- if (!is.null(edges$weight)) {
|
| 118 | 2x |
ifelse(edges$weight > 0, pos_col, ifelse(edges$weight < 0, neg_col, default_col)) |
| 119 |
} else {
|
|
| 120 | 2x |
rep(default_col, m) |
| 121 |
} |
|
| 122 |
} |
|
| 123 | ||
| 124 | 24x |
edge_alphas <- recycle_to_length( |
| 125 | 24x |
if (!is.null(edge_aes$alpha)) edge_aes$alpha else 0.8, |
| 126 | 24x |
m |
| 127 |
) |
|
| 128 | ||
| 129 | 24x |
edge_df <- data.frame( |
| 130 | 24x |
x = nodes$x[edges$from], |
| 131 | 24x |
y = nodes$y[edges$from], |
| 132 | 24x |
xend = nodes$x[edges$to], |
| 133 | 24x |
yend = nodes$y[edges$to], |
| 134 | 24x |
width = edge_widths, |
| 135 | 24x |
color = edge_colors, |
| 136 | 24x |
alpha = edge_alphas, |
| 137 | 24x |
stringsAsFactors = FALSE |
| 138 |
) |
|
| 139 |
} else {
|
|
| 140 | 2x |
edge_df <- NULL |
| 141 |
} |
|
| 142 | ||
| 143 |
# Create base plot |
|
| 144 | 26x |
p <- ggplot2::ggplot() |
| 145 | ||
| 146 |
# Add edges |
|
| 147 | 26x |
if (!is.null(edge_df) && nrow(edge_df) > 0) {
|
| 148 | 24x |
show_arrows <- if (!is.null(edge_aes$show_arrows)) edge_aes$show_arrows else net$is_directed |
| 149 | ||
| 150 | 24x |
if (show_arrows) {
|
| 151 | 2x |
p <- p + ggplot2::geom_segment( |
| 152 | 2x |
data = edge_df, |
| 153 | 2x |
ggplot2::aes(x = .data$x, y = .data$y, xend = .data$xend, yend = .data$yend), |
| 154 | 2x |
color = edge_df$color, |
| 155 | 2x |
linewidth = edge_df$width, |
| 156 | 2x |
alpha = edge_df$alpha, |
| 157 | 2x |
arrow = ggplot2::arrow(length = ggplot2::unit(0.15, "cm"), type = "closed") |
| 158 |
) |
|
| 159 |
} else {
|
|
| 160 | 22x |
p <- p + ggplot2::geom_segment( |
| 161 | 22x |
data = edge_df, |
| 162 | 22x |
ggplot2::aes(x = .data$x, y = .data$y, xend = .data$xend, yend = .data$yend), |
| 163 | 22x |
color = edge_df$color, |
| 164 | 22x |
linewidth = edge_df$width, |
| 165 | 22x |
alpha = edge_df$alpha |
| 166 |
) |
|
| 167 |
} |
|
| 168 |
} |
|
| 169 | ||
| 170 |
# Add nodes |
|
| 171 | 26x |
p <- p + ggplot2::geom_point( |
| 172 | 26x |
data = node_df, |
| 173 | 26x |
ggplot2::aes(x = .data$x, y = .data$y), |
| 174 | 26x |
fill = node_df$fill, |
| 175 | 26x |
color = node_df$border, |
| 176 | 26x |
size = node_df$size, |
| 177 | 26x |
stroke = node_df$border_width, |
| 178 | 26x |
alpha = node_df$alpha, |
| 179 | 26x |
shape = node_df$shape |
| 180 |
) |
|
| 181 | ||
| 182 |
# Add labels |
|
| 183 | 26x |
show_labels <- if (!is.null(node_aes$show_labels)) node_aes$show_labels else TRUE |
| 184 | 26x |
if (show_labels) {
|
| 185 | 26x |
label_size <- if (!is.null(node_aes$label_size)) node_aes$label_size[1] else |
| 186 | 26x |
if (!is.null(theme)) theme$get("label_size") else 10
|
| 187 | 26x |
label_color <- if (!is.null(node_aes$label_color)) node_aes$label_color[1] else |
| 188 | 26x |
if (!is.null(theme)) theme$get("label_color") else "black"
|
| 189 | ||
| 190 | 26x |
p <- p + ggplot2::geom_text( |
| 191 | 26x |
data = node_df, |
| 192 | 26x |
ggplot2::aes(x = .data$x, y = .data$y, label = .data$label), |
| 193 | 26x |
color = label_color, |
| 194 | 26x |
size = label_size / 3 # Convert to ggplot2 sizing |
| 195 |
) |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# Apply theme |
|
| 199 | 26x |
p <- p + |
| 200 | 26x |
ggplot2::coord_fixed(ratio = 1) + |
| 201 | 26x |
ggplot2::theme_void() + |
| 202 | 26x |
ggplot2::theme( |
| 203 | 26x |
panel.background = ggplot2::element_rect(fill = bg_color, color = NA), |
| 204 | 26x |
plot.background = ggplot2::element_rect(fill = bg_color, color = NA) |
| 205 |
) |
|
| 206 | ||
| 207 |
# Add title |
|
| 208 | 26x |
if (!is.null(title)) {
|
| 209 | 4x |
p <- p + ggplot2::ggtitle(title) |
| 210 |
} |
|
| 211 | ||
| 212 | 26x |
p |
| 213 |
} |
| 1 |
#' @title Oval/Ellipse Layout |
|
| 2 |
#' @description Arrange nodes in an oval (ellipse) shape. |
|
| 3 |
#' @name layout-oval |
|
| 4 |
NULL |
|
| 5 | ||
| 6 |
#' Oval Layout |
|
| 7 |
#' |
|
| 8 |
#' Arrange nodes evenly spaced around an ellipse. This creates an oval-shaped |
|
| 9 |
#' network layout that is wider than it is tall (or vice versa depending on ratio). |
|
| 10 |
#' |
|
| 11 |
#' @param network A CographNetwork object. |
|
| 12 |
#' @param ratio Aspect ratio (width/height). Values > 1 create horizontal ovals, |
|
| 13 |
#' values < 1 create vertical ovals. Default 1.5. |
|
| 14 |
#' @param order Optional vector specifying node order (indices or labels). |
|
| 15 |
#' @param start_angle Starting angle in radians (default: pi/2 for top). |
|
| 16 |
#' @param clockwise Logical. Arrange nodes clockwise? Default TRUE. |
|
| 17 |
#' @param rotation Rotation angle in radians to tilt the entire oval. Default 0. |
|
| 18 |
#' @return Data frame with x, y coordinates. |
|
| 19 |
#' @export |
|
| 20 |
#' |
|
| 21 |
#' @examples |
|
| 22 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 23 |
#' net <- CographNetwork$new(adj) |
|
| 24 |
#' coords <- layout_oval(net, ratio = 1.5) |
|
| 25 |
layout_oval <- function(network, ratio = 1.5, order = NULL, start_angle = pi/2, |
|
| 26 |
clockwise = TRUE, rotation = 0) {
|
|
| 27 | 449x |
n <- network$n_nodes |
| 28 | ||
| 29 | 449x |
if (n == 0) {
|
| 30 | 1x |
return(data.frame(x = numeric(0), y = numeric(0))) |
| 31 |
} |
|
| 32 | ||
| 33 | 448x |
if (n == 1) {
|
| 34 | 3x |
return(data.frame(x = 0.5, y = 0.5)) |
| 35 |
} |
|
| 36 | ||
| 37 |
# Determine node order |
|
| 38 | 445x |
if (!is.null(order)) {
|
| 39 | 4x |
if (is.character(order)) {
|
| 40 |
# Convert labels to indices |
|
| 41 | 1x |
labels <- network$node_labels |
| 42 | 1x |
order <- match(order, labels) |
| 43 | 1x |
if (any(is.na(order))) {
|
| 44 | 1x |
warning("Some labels not found, using default order")
|
| 45 | 1x |
order <- seq_len(n) |
| 46 |
} |
|
| 47 |
} |
|
| 48 | 4x |
if (length(order) != n) {
|
| 49 | 1x |
warning("Order length doesn't match node count, using default order")
|
| 50 | 1x |
order <- seq_len(n) |
| 51 |
} |
|
| 52 |
} else {
|
|
| 53 | 441x |
order <- seq_len(n) |
| 54 |
} |
|
| 55 | ||
| 56 |
# Calculate angles for each node |
|
| 57 | 445x |
angles <- seq(start_angle, start_angle + 2 * pi * (1 - 1/n), |
| 58 | 445x |
length.out = n) |
| 59 | 445x |
if (clockwise) {
|
| 60 | 444x |
angles <- rev(angles) |
| 61 |
} |
|
| 62 | ||
| 63 |
# Calculate ellipse radii based on ratio |
|
| 64 |
# Keep the area roughly similar to a unit circle |
|
| 65 |
# For ellipse: area = pi * a * b, for circle: area = pi * r^2 |
|
| 66 |
# If we want same area: a * b = r^2 = 0.16 (for r = 0.4) |
|
| 67 |
# With a = ratio * b: ratio * b^2 = 0.16, so b = sqrt(0.16/ratio) |
|
| 68 | 445x |
base_radius <- 0.4 |
| 69 | 445x |
radius_x <- base_radius * sqrt(ratio) |
| 70 | 445x |
radius_y <- base_radius / sqrt(ratio) |
| 71 | ||
| 72 |
# Calculate coordinates on ellipse |
|
| 73 | 445x |
x <- 0.5 + radius_x * cos(angles) |
| 74 | 445x |
y <- 0.5 + radius_y * sin(angles) |
| 75 | ||
| 76 |
# Apply rotation if specified |
|
| 77 | ||
| 78 | 445x |
if (rotation != 0) {
|
| 79 |
# Rotate around center (0.5, 0.5) |
|
| 80 | 1x |
x_centered <- x - 0.5 |
| 81 | 1x |
y_centered <- y - 0.5 |
| 82 | ||
| 83 | 1x |
x_rotated <- x_centered * cos(rotation) - y_centered * sin(rotation) |
| 84 | 1x |
y_rotated <- x_centered * sin(rotation) + y_centered * cos(rotation) |
| 85 | ||
| 86 | 1x |
x <- x_rotated + 0.5 |
| 87 | 1x |
y <- y_rotated + 0.5 |
| 88 |
} |
|
| 89 | ||
| 90 |
# Reorder if needed |
|
| 91 | 445x |
coords <- data.frame(x = x, y = y) |
| 92 | 445x |
coords[order, ] <- coords |
| 93 | ||
| 94 | 445x |
coords |
| 95 |
} |
| 1 |
#' @title Circular Layout |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Arrange nodes in a circle. |
|
| 4 |
#' @name layout-circle |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Circular Layout |
|
| 8 |
#' |
|
| 9 |
#' Arrange nodes evenly spaced around a circle. |
|
| 10 |
#' |
|
| 11 |
#' @param network A CographNetwork object. |
|
| 12 |
#' @param order Optional vector specifying node order (indices or labels). |
|
| 13 |
#' @param start_angle Starting angle in radians (default: pi/2 for top). |
|
| 14 |
#' @param clockwise Logical. Arrange nodes clockwise? Default TRUE. |
|
| 15 |
#' @return Data frame with x, y coordinates. |
|
| 16 |
#' @export |
|
| 17 |
#' |
|
| 18 |
#' @examples |
|
| 19 |
#' adj <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), nrow = 3) |
|
| 20 |
#' net <- CographNetwork$new(adj) |
|
| 21 |
#' coords <- layout_circle(net) |
|
| 22 |
layout_circle <- function(network, order = NULL, start_angle = pi/2, |
|
| 23 |
clockwise = TRUE) {
|
|
| 24 | 397x |
n <- network$n_nodes |
| 25 | ||
| 26 | 397x |
if (n == 0) {
|
| 27 | 1x |
return(data.frame(x = numeric(0), y = numeric(0))) |
| 28 |
} |
|
| 29 | ||
| 30 | 396x |
if (n == 1) {
|
| 31 | 4x |
return(data.frame(x = 0.5, y = 0.5)) |
| 32 |
} |
|
| 33 | ||
| 34 |
# Determine node order |
|
| 35 | 392x |
if (!is.null(order)) {
|
| 36 | 5x |
if (is.character(order)) {
|
| 37 |
# Convert labels to indices |
|
| 38 | 2x |
labels <- network$node_labels |
| 39 | 2x |
order <- match(order, labels) |
| 40 | 2x |
if (any(is.na(order))) {
|
| 41 | 1x |
warning("Some labels not found, using default order")
|
| 42 | 1x |
order <- seq_len(n) |
| 43 |
} |
|
| 44 |
} |
|
| 45 | 5x |
if (length(order) != n) {
|
| 46 | 1x |
warning("Order length doesn't match node count, using default order")
|
| 47 | 1x |
order <- seq_len(n) |
| 48 |
} |
|
| 49 |
} else {
|
|
| 50 | 387x |
order <- seq_len(n) |
| 51 |
} |
|
| 52 | ||
| 53 |
# Calculate angles |
|
| 54 | 392x |
angles <- seq(start_angle, start_angle + 2 * pi * (1 - 1/n), |
| 55 | 392x |
length.out = n) |
| 56 | 392x |
if (clockwise) {
|
| 57 | 391x |
angles <- rev(angles) |
| 58 |
} |
|
| 59 | ||
| 60 |
# Calculate coordinates |
|
| 61 | 392x |
x <- 0.5 + 0.4 * cos(angles) |
| 62 | 392x |
y <- 0.5 + 0.4 * sin(angles) |
| 63 | ||
| 64 |
# Reorder if needed |
|
| 65 | 392x |
coords <- data.frame(x = x, y = y) |
| 66 | 392x |
coords[order, ] <- coords |
| 67 | ||
| 68 | 392x |
coords |
| 69 |
} |
| 1 |
#' @title Matrix Input Parsing |
|
| 2 |
#' @keywords internal |
|
| 3 |
#' @description Functions for parsing adjacency/weight matrices. |
|
| 4 |
#' @name input-matrix |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Parse Adjacency/Weight Matrix |
|
| 8 |
#' |
|
| 9 |
#' Convert an adjacency or weight matrix to internal network format. |
|
| 10 |
#' |
|
| 11 |
#' @param m A square matrix. Symmetric matrices are treated as undirected, |
|
| 12 |
#' asymmetric as directed. Values represent edge weights. |
|
| 13 |
#' @param directed Logical. Force directed interpretation. NULL for auto-detect. |
|
| 14 |
#' @return List with nodes, edges, directed, and weights components. |
|
| 15 |
#' @noRd |
|
| 16 |
parse_matrix <- function(m, directed = NULL) {
|
|
| 17 |
# Validate input |
|
| 18 | 1680x |
if (!is.matrix(m)) {
|
| 19 | 1x |
stop("Input must be a matrix", call. = FALSE)
|
| 20 |
} |
|
| 21 | 1679x |
if (!is.numeric(m)) {
|
| 22 | 1x |
stop("Matrix must be numeric", call. = FALSE)
|
| 23 |
} |
|
| 24 | 1678x |
if (nrow(m) != ncol(m)) {
|
| 25 | 3x |
stop("Matrix must be square", call. = FALSE)
|
| 26 |
} |
|
| 27 | ||
| 28 | 1675x |
n <- nrow(m) |
| 29 | ||
| 30 |
# Get node labels from dimnames |
|
| 31 | 1675x |
labels <- rownames(m) |
| 32 | 1675x |
if (is.null(labels)) {
|
| 33 | 1553x |
labels <- colnames(m) |
| 34 |
} |
|
| 35 | 1675x |
if (is.null(labels)) {
|
| 36 | 1552x |
labels <- as.character(seq_len(n)) |
| 37 |
} |
|
| 38 | ||
| 39 |
# Auto-detect directed |
|
| 40 | 1675x |
if (is.null(directed)) {
|
| 41 | 1654x |
directed <- !is_symmetric_matrix(m) |
| 42 |
} |
|
| 43 | ||
| 44 |
# Extract edges |
|
| 45 | 1675x |
if (directed) {
|
| 46 |
# For directed: all non-zero entries |
|
| 47 | 148x |
idx <- which(m != 0, arr.ind = TRUE) |
| 48 | 148x |
from <- idx[, 1] |
| 49 | 148x |
to <- idx[, 2] |
| 50 | 148x |
weight <- m[idx] |
| 51 |
} else {
|
|
| 52 |
# For undirected: upper triangle only (avoid duplicates) |
|
| 53 | 1527x |
idx <- which(upper.tri(m) & m != 0, arr.ind = TRUE) |
| 54 | 1527x |
from <- idx[, 1] |
| 55 | 1527x |
to <- idx[, 2] |
| 56 | 1527x |
weight <- m[idx] |
| 57 |
} |
|
| 58 | ||
| 59 |
# Create data structures |
|
| 60 | 1675x |
nodes <- create_nodes_df(n, labels) |
| 61 | 1673x |
edges <- create_edges_df(from, to, weight, directed) |
| 62 | ||
| 63 | 1673x |
list( |
| 64 | 1673x |
nodes = nodes, |
| 65 | 1673x |
edges = edges, |
| 66 | 1673x |
directed = directed, |
| 67 | 1673x |
weights = weight |
| 68 |
) |
|
| 69 |
} |
| 1 |
#' @title Color Utilities |
|
| 2 |
#' @description Utility functions for color manipulation. |
|
| 3 |
#' @name utils-colors |
|
| 4 |
#' @keywords internal |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Adjust Color Alpha |
|
| 8 |
#' @noRd |
|
| 9 |
adjust_alpha <- function(color, alpha = 1) {
|
|
| 10 | 9561x |
if (is.na(color) || is.null(color)) {
|
| 11 | 2x |
return(NA_character_) |
| 12 |
} |
|
| 13 | ||
| 14 |
# Handle transparent |
|
| 15 | 9559x |
if (color == "transparent") {
|
| 16 | 1x |
return("transparent")
|
| 17 |
} |
|
| 18 | ||
| 19 |
# Convert to RGB |
|
| 20 | 9558x |
rgb_vals <- tryCatch( |
| 21 | 9558x |
grDevices::col2rgb(color, alpha = TRUE), |
| 22 | 9558x |
error = function(e) NULL |
| 23 |
) |
|
| 24 | ||
| 25 | 9558x |
if (is.null(rgb_vals)) {
|
| 26 | 1x |
return(color) |
| 27 |
} |
|
| 28 | ||
| 29 |
# Apply alpha |
|
| 30 | 9557x |
grDevices::rgb( |
| 31 | 9557x |
rgb_vals[1, 1], |
| 32 | 9557x |
rgb_vals[2, 1], |
| 33 | 9557x |
rgb_vals[3, 1], |
| 34 | 9557x |
alpha = round(alpha * 255), |
| 35 | 9557x |
maxColorValue = 255 |
| 36 |
) |
|
| 37 |
} |
|
| 38 | ||
| 39 |
#' Lighten or Darken Color |
|
| 40 |
#' @noRd |
|
| 41 |
adjust_brightness <- function(color, amount = 0.2) {
|
|
| 42 | 2665x |
if (is.na(color) || is.null(color)) {
|
| 43 | 3x |
return(NA_character_) |
| 44 |
} |
|
| 45 | ||
| 46 | 2662x |
rgb_vals <- grDevices::col2rgb(color) |
| 47 | ||
| 48 | 2662x |
if (amount > 0) {
|
| 49 |
# Lighten |
|
| 50 | 1x |
rgb_vals <- rgb_vals + (255 - rgb_vals) * amount |
| 51 |
} else {
|
|
| 52 |
# Darken |
|
| 53 | 2661x |
rgb_vals <- rgb_vals * (1 + amount) |
| 54 |
} |
|
| 55 | ||
| 56 | 2662x |
rgb_vals <- pmax(0, pmin(255, rgb_vals)) |
| 57 | ||
| 58 | 2662x |
grDevices::rgb(rgb_vals[1], rgb_vals[2], rgb_vals[3], |
| 59 | 2662x |
maxColorValue = 255) |
| 60 |
} |
|
| 61 | ||
| 62 |
#' Interpolate Between Colors |
|
| 63 |
#' @noRd |
|
| 64 |
interpolate_colors <- function(color1, color2, n) {
|
|
| 65 | 2x |
grDevices::colorRampPalette(c(color1, color2))(n) |
| 66 |
} |
|
| 67 | ||
| 68 |
#' Get Contrasting Text Color |
|
| 69 |
#' @noRd |
|
| 70 |
contrast_text_color <- function(bg_color) {
|
|
| 71 | 7x |
if (is.na(bg_color) || is.null(bg_color) || bg_color == "transparent") {
|
| 72 | 3x |
return("black")
|
| 73 |
} |
|
| 74 | ||
| 75 | 4x |
rgb_vals <- grDevices::col2rgb(bg_color) |
| 76 | ||
| 77 |
# Calculate relative luminance |
|
| 78 | 4x |
luminance <- (0.299 * rgb_vals[1, 1] + 0.587 * rgb_vals[2, 1] + |
| 79 | 4x |
0.114 * rgb_vals[3, 1]) / 255 |
| 80 | ||
| 81 | 2x |
if (luminance > 0.5) "black" else "white" |
| 82 |
} |
|
| 83 | ||
| 84 |
#' Map Values to Colors |
|
| 85 |
#' @noRd |
|
| 86 |
map_to_colors <- function(values, colors, limits = NULL) {
|
|
| 87 | 7x |
if (is.null(limits)) {
|
| 88 | 4x |
limits <- range(values, na.rm = TRUE) |
| 89 |
} |
|
| 90 | ||
| 91 |
# Normalize values to [0, 1] |
|
| 92 | 7x |
normalized <- (values - limits[1]) / (limits[2] - limits[1]) |
| 93 | 7x |
normalized <- pmax(0, pmin(1, normalized)) |
| 94 | ||
| 95 |
# Create color ramp |
|
| 96 | 7x |
ramp <- grDevices::colorRamp(colors) |
| 97 | ||
| 98 |
# Map values |
|
| 99 | 7x |
rgb_matrix <- ramp(normalized) |
| 100 | 7x |
grDevices::rgb(rgb_matrix[, 1], rgb_matrix[, 2], rgb_matrix[, 3], |
| 101 | 7x |
maxColorValue = 255) |
| 102 |
} |
| 1 |
#' @title Built-in Themes |
|
| 2 |
#' @description Pre-defined themes for network visualization. |
|
| 3 |
#' @keywords internal |
|
| 4 |
#' @name themes-builtin |
|
| 5 |
NULL |
|
| 6 | ||
| 7 |
#' Classic Theme |
|
| 8 |
#' |
|
| 9 |
#' Traditional network visualization style with blue nodes and gray edges. |
|
| 10 |
#' |
|
| 11 |
#' @return A CographTheme object. |
|
| 12 |
#' @export |
|
| 13 |
#' @examples |
|
| 14 |
#' theme <- theme_cograph_classic() |
|
| 15 |
theme_cograph_classic <- function() {
|
|
| 16 | 12x |
CographTheme$new( |
| 17 | 12x |
name = "classic", |
| 18 | 12x |
background = "white", |
| 19 | 12x |
node_fill = "#4A90D9", |
| 20 | 12x |
node_border = "#2C5AA0", |
| 21 | 12x |
node_border_width = 1.5, |
| 22 | 12x |
edge_color = "gray50", |
| 23 | 12x |
edge_positive_color = "#2E7D32", |
| 24 | 12x |
edge_negative_color = "#C62828", |
| 25 | 12x |
edge_width = 1, |
| 26 | 12x |
label_color = "black", |
| 27 | 12x |
label_size = 10, |
| 28 | 12x |
title_color = "black", |
| 29 | 12x |
title_size = 14, |
| 30 | 12x |
legend_background = "white" |
| 31 |
) |
|
| 32 |
} |
|
| 33 | ||
| 34 |
#' Colorblind-friendly Theme |
|
| 35 |
#' |
|
| 36 |
#' Theme using colors distinguishable by people with color vision deficiency. |
|
| 37 |
#' |
|
| 38 |
#' @return A CographTheme object. |
|
| 39 |
#' @export |
|
| 40 |
#' @examples |
|
| 41 |
#' theme <- theme_cograph_colorblind() |
|
| 42 |
theme_cograph_colorblind <- function() {
|
|
| 43 | 4x |
CographTheme$new( |
| 44 | 4x |
name = "colorblind", |
| 45 | 4x |
background = "white", |
| 46 | 4x |
node_fill = "#0072B2", |
| 47 | 4x |
node_border = "#004C7F", |
| 48 | 4x |
node_border_width = 1.5, |
| 49 | 4x |
edge_color = "gray50", |
| 50 | 4x |
edge_positive_color = "#0000FF", |
| 51 | 4x |
edge_negative_color = "#FF0000", |
| 52 | 4x |
edge_width = 1, |
| 53 | 4x |
label_color = "black", |
| 54 | 4x |
label_size = 10, |
| 55 | 4x |
title_color = "black", |
| 56 | 4x |
title_size = 14, |
| 57 | 4x |
legend_background = "white" |
| 58 |
) |
|
| 59 |
} |
|
| 60 | ||
| 61 |
#' Grayscale Theme |
|
| 62 |
#' |
|
| 63 |
#' Black and white theme suitable for print. |
|
| 64 |
#' |
|
| 65 |
#' @return A CographTheme object. |
|
| 66 |
#' @export |
|
| 67 |
#' @examples |
|
| 68 |
#' theme <- theme_cograph_gray() |
|
| 69 |
theme_cograph_gray <- function() {
|
|
| 70 | 5x |
CographTheme$new( |
| 71 | 5x |
name = "gray", |
| 72 | 5x |
background = "white", |
| 73 | 5x |
node_fill = "gray70", |
| 74 | 5x |
node_border = "gray30", |
| 75 | 5x |
node_border_width = 1.5, |
| 76 | 5x |
edge_color = "gray50", |
| 77 | 5x |
edge_positive_color = "gray20", |
| 78 | 5x |
edge_negative_color = "gray60", |
| 79 | 5x |
edge_width = 1, |
| 80 | 5x |
label_color = "black", |
| 81 | 5x |
label_size = 10, |
| 82 | 5x |
title_color = "black", |
| 83 | 5x |
title_size = 14, |
| 84 | 5x |
legend_background = "white" |
| 85 |
) |
|
| 86 |
} |
|
| 87 | ||
| 88 |
#' Dark Theme |
|
| 89 |
#' |
|
| 90 |
#' Dark background theme for presentations. |
|
| 91 |
#' |
|
| 92 |
#' @return A CographTheme object. |
|
| 93 |
#' @export |
|
| 94 |
#' @examples |
|
| 95 |
#' theme <- theme_cograph_dark() |
|
| 96 |
theme_cograph_dark <- function() {
|
|
| 97 | 6x |
CographTheme$new( |
| 98 | 6x |
name = "dark", |
| 99 | 6x |
background = "#1a1a2e", |
| 100 | 6x |
node_fill = "#e94560", |
| 101 | 6x |
node_border = "#ff6b6b", |
| 102 | 6x |
node_border_width = 1.5, |
| 103 | 6x |
edge_color = "gray60", |
| 104 | 6x |
edge_positive_color = "#4ecca3", |
| 105 | 6x |
edge_negative_color = "#fc5185", |
| 106 | 6x |
edge_width = 1, |
| 107 | 6x |
label_color = "white", |
| 108 | 6x |
label_size = 10, |
| 109 | 6x |
title_color = "white", |
| 110 | 6x |
title_size = 14, |
| 111 | 6x |
legend_background = "#1a1a2e" |
| 112 |
) |
|
| 113 |
} |
|
| 114 | ||
| 115 |
#' Minimal Theme |
|
| 116 |
#' |
|
| 117 |
#' Clean, minimal style with thin borders. |
|
| 118 |
#' |
|
| 119 |
#' @return A CographTheme object. |
|
| 120 |
#' @export |
|
| 121 |
#' @examples |
|
| 122 |
#' theme <- theme_cograph_minimal() |
|
| 123 |
theme_cograph_minimal <- function() {
|
|
| 124 | 3x |
CographTheme$new( |
| 125 | 3x |
name = "minimal", |
| 126 | 3x |
background = "white", |
| 127 | 3x |
node_fill = "white", |
| 128 | 3x |
node_border = "gray40", |
| 129 | 3x |
node_border_width = 0.75, |
| 130 | 3x |
edge_color = "gray70", |
| 131 | 3x |
edge_positive_color = "gray40", |
| 132 | 3x |
edge_negative_color = "gray40", |
| 133 | 3x |
edge_width = 0.5, |
| 134 | 3x |
label_color = "gray30", |
| 135 | 3x |
label_size = 9, |
| 136 | 3x |
title_color = "gray20", |
| 137 | 3x |
title_size = 12, |
| 138 | 3x |
legend_background = "white" |
| 139 |
) |
|
| 140 |
} |
|
| 141 | ||
| 142 |
#' Viridis Theme |
|
| 143 |
#' |
|
| 144 |
#' Theme using viridis color palette. |
|
| 145 |
#' |
|
| 146 |
#' @return A CographTheme object. |
|
| 147 |
#' @export |
|
| 148 |
#' @examples |
|
| 149 |
#' theme <- theme_cograph_viridis() |
|
| 150 |
theme_cograph_viridis <- function() {
|
|
| 151 | 3x |
CographTheme$new( |
| 152 | 3x |
name = "viridis", |
| 153 | 3x |
background = "white", |
| 154 | 3x |
node_fill = "#21918c", |
| 155 | 3x |
node_border = "#31688e", |
| 156 | 3x |
node_border_width = 1.5, |
| 157 | 3x |
edge_color = "gray50", |
| 158 | 3x |
edge_positive_color = "#5ec962", |
| 159 | 3x |
edge_negative_color = "#b5367a", |
| 160 | 3x |
edge_width = 1, |
| 161 | 3x |
label_color = "black", |
| 162 | 3x |
label_size = 10, |
| 163 | 3x |
title_color = "black", |
| 164 | 3x |
title_size = 14, |
| 165 | 3x |
legend_background = "white" |
| 166 |
) |
|
| 167 |
} |
|
| 168 | ||
| 169 |
#' Nature Theme |
|
| 170 |
#' |
|
| 171 |
#' Earth tones theme inspired by nature. |
|
| 172 |
#' |
|
| 173 |
#' @return A CographTheme object. |
|
| 174 |
#' @export |
|
| 175 |
#' @examples |
|
| 176 |
#' theme <- theme_cograph_nature() |
|
| 177 |
theme_cograph_nature <- function() {
|
|
| 178 | 3x |
CographTheme$new( |
| 179 | 3x |
name = "nature", |
| 180 | 3x |
background = "#fefae0", |
| 181 | 3x |
node_fill = "#606c38", |
| 182 | 3x |
node_border = "#283618", |
| 183 | 3x |
node_border_width = 1.5, |
| 184 | 3x |
edge_color = "#bc6c25", |
| 185 | 3x |
edge_positive_color = "#606c38", |
| 186 | 3x |
edge_negative_color = "#9b2226", |
| 187 | 3x |
edge_width = 1, |
| 188 | 3x |
label_color = "#283618", |
| 189 | 3x |
label_size = 10, |
| 190 | 3x |
title_color = "#283618", |
| 191 | 3x |
title_size = 14, |
| 192 | 3x |
legend_background = "#fefae0" |
| 193 |
) |
|
| 194 |
} |